| |
Коллекция полезных функций
Альтернатива DLookUp
Public Function SqlLookUp(sql)
Dim ar
On Error Resume Next
ar = CurrentProject.connection.Execute(sql).GetRows
SqlLookUp = ar(0, 0)
End Function
Вариант 2
Public Function SqlLookUp(sql)
On Error Resume Next
SqlLookUp = CurrentProject.Connection.Execute(sql).Fields(0)
End Function
Вызов функции из вычисляемого поля:
= SqlLookUp(" select a + b + c from mytable where id=" & [formID] )
Функция возвратит первое значение (первая строка и первое поле) из набора записей определяемого параметром SQL
Функция максимизации формы
Преимущество перед классическим способом
работает быстрее если фома уже максимизирована
не вызывает предергивания экрана.
Declare Function IsZoomed Lib "user32" (ByVal hwnd As Long) As Long
Sub FormMaximize()
On Error Resume Next
If Not IsZoomed(Screen.ActiveForm.hwnd) Then
Echo False
DoCmd.Maximize
Echo True
End If
End Sub
Вызов из события загрузка формы:
Call FormMaximize()
Переоткрытие формы или отчета:
Если отчет вызывается из формы, которая впоследствии остается открытой,
в случае если открываемая форма или отчет не были закрыты, то в случае повторного вызова можно обнаружить, что критерии отбора данных изменены,
а данные в открываемом отчете - старые. Во избежание такого эффекта используем для открытия следующие функции:
Public Sub Reload_form(FRM_NAME As String, Optional WM As AcWindowMode = acWindowNormal, Optional openarg As String)
If CurrentProject.AllForms(FRM_NAME).IsLoaded Then DoCmd.Close acForm, FRM_NAME
DoCmd.OpenForm FRM_NAME, , , , , WM, openarg
End Sub
Public Sub Reload_Report(REP_NAME As String, Optional View As Access.AcView = acViewPreview, Optional ARGS As String)
'openargs в отчетах начиная с Acc 2002
If CurrentProject.AllReports(REP_NAME).IsLoaded Then DoCmd.Close acReport, REP_NAME
DoCmd.OpenReport REP_NAME, View, , , , ARGS
End Sub
Функции сохранения значения
контрола на форме
в реестр и
извлечения из него
Сохранение в реестр:
Public Sub SetRegistry(Ctl As Control)
Call SaveSetting(Left(CurrentProject.NAME, Len(CurrentProject.NAME) - 4), Ctl.Parent.NAME, Ctl.NAME, Ctl.value)
End Sub
Извлечение из реестра:
Public Sub GetRegistry(Ctl As Control, Optional DefaultValue)
Dim v1
v1 = GetSetting(Left(CurrentProject.NAME, Len(CurrentProject.NAME) - 4), Ctl.Parent.NAME, Ctl.NAME)
If v1 = "" Then Ctl.value = DefaultValue Else Ctl.value = v1
End Sub
Сохранение в реестр обычно помещается в событие выгрузка формы
Call SetRegistry(me.Поле1)
Извлечение из реестра
обычно в событии загрузка формы
Второй параметр опционален и может содержать значение по умолчанию на тот случай, если в реестре ничего нет (первая загрузка)
Call GetRegistry(me.ПолеДаты)
или
Call GetRegistry(me.ПолеДаты, date())
Курс валют ЦБРФ
Функция получения курса из таблицы с автозакачкой в случае необходимости:
Для работы данной функции необходимы подключенные в Ссылках референсы на библиотеки
MS ADO 2.6
MS XML 2.0
и нижеприведенные вспомогательные функции.
Option Explicit
Private Error_load_xml As Boolean
Public Selected_retry_abort_ignore 'нет соединения- повторить прервать игнорировать
Public Function Get_Course_USD(onDate As Date)
Dim tm
Dim Srv_date As Date
Dim LAST_course_date As Date
'запросить с сервера текущую дату
tm = CurrentProject.Connection.Execute("select getdate() as serv_date ").GetRows
Srv_date = tm(0, 0)
'запросить с сервера дату последнего курса доллара
tm = CurrentProject.Connection.Execute("SELECT TOP 1 DATE_VALute AS last_date from dbo.VALUTe ORDER BY DATE_VALute DESC").GetRows
LAST_course_date = tm(0, 0)
'если есть недостающие данные то добавить из интернета курсы доллара за этот диапазон
If Int(LAST_course_date) < Int(Srv_date) Then
Call Course_2_table(LAST_course_date, Srv_date)
End If
'запросить курс из таблицы на дату
tm = CurrentProject.Connection.Execute("select dbo.get_course_finctrl (" & Clng(onDate)- 2 & ") as c_usd ").GetRows
Get_Course_USD = tm(0, 0)
If onDate > Srv_date Then
'если дата сервера > даты запроса
'сообщение о некорректности операции
If Selected_retry_abort_ignore <> vbAbort Then MsgBox "Курс доллара на запрашиваемую дату неизвестен, будет использовано последнее известное значение"
End If
End Function
Вспомогательные функции:
1. Функция загрузки курса доллара в таблицу на сервере за период времени
Private Sub Course_2_table(Datefrom As Date, Dateto As Date)
Dim nodelist, iIndex
Dim xmlNode As MSXML.IXMLDOMNode
Dim node_attr As MSXML.IXMLDOMAttribute
Dim rst As New ADODB.Recordset
Dim conn As New ADODB.Connection
Set nodelist = xmldoc(Datefrom, Dateto).selectNodes("*/Record")
If Error_load_xml Then Exit Sub
conn.Open CurrentProject.Connection.ConnectionString
conn.BeginTrans
conn.Execute ("delete from valute where date_valute between " & clng(Datefrom)-2 & " and " & clng(Dateto)-2)
rst.Open "select * from dbo.valute where idvalute = 0 ", conn, adOpenDynamic, adLockOptimistic
For iIndex = 0 To nodelist.length - 1
Set xmlNode = nodelist.Item(iIndex).cloneNode(True)
Set node_attr = xmlNode.Attributes(0)
rst.AddNew
rst!USD = Replace(Replace(xmlNode.childNodes(1).Text, ",", ".", 1, , vbBinaryCompare), Chr(160), "", 1, , vbBinaryCompare)
' Это значение
rst!Date_valute = node_attr.value ' Это дата
rst.Update
Next
conn.CommitTrans
rst.Close
Set rst = Nothing
conn.Close
Set conn = Nothing
End Sub
2. Функция для закачки курса из интернет
Private Function xmldoc(Datefrom As Date, Dateto As Date)
Dim url_request
' Создаем экземпляр объекта - XML парзера
Set xmldoc = CreateObject("Msxml.DOMDocument")
xmldoc.async = False
'запрос к серверу центробанка в принятом формате на получение xml документа , разумно вынести даты как переменные а процедуру преобразовать в функцию
url_request = "http://www.cbr.ru/scripts/XML_dynamic.asp?date_req1=" & Format(Datefrom, "dd.mm.yyyy") & "&date_req2=" & Format(Dateto, "dd.mm.yyyy") & "&VAL_NM_RQ=R01235"
' загружаем документ по url
rl:
If Not xmldoc.Load(url_request) = True Then
Error_load_xml = True
Selected_retry_abort_ignore = MsgBox("Невозможно установить связь с сервером Центробанка для получения курса доллара, возможно отсутствует соединение с Интернет", vbAbortRetryIgnore)
If Selected_retry_abort_ignore = vbRetry Then GoTo rl:
Exit Function
End If
Selected_retry_abort_ignore = 0
Error_load_xml = False
End Function
Описание структуры таблицы в которую будут помещены данные
Название Тип размер прочее
id int 4 not null, identity Primary key
NumCode int 4
CharCode nvarchar 255
Nominal int 4
Name nvarchar 255
Value real 4
date datetime 8
Скрипт таблицы:
CREATE TABLE [dbo].[Valute] (
[NumCode] [int] NULL ,
[CharCode] [nvarchar] (255) COLLATE SQL_Latin1_General_CP1251_CI_AS NULL ,
[Nominal] [int] NULL ,
[Name] [nvarchar] (255) COLLATE SQL_Latin1_General_CP1251_CI_AS NULL ,
[Value] [real] NULL ,
[date] [datetime] NULL ,
[id] [int] IDENTITY (1, 1) NOT NULL
) ON [PRIMARY]
Подсказка для новичков:
Для создания таблицы достаточно скопировать данный скрипт в Query analyzer , подключенный к вашей базе или в новую хранимую процедуру в Аксессе (между AS и RETURN )и выполнить его.
| |
