' Для тех, кому интересно покопаться в Access несколько более глубоко, чем предлагается в учебниках, в этой статье хочется предложить пару-другую приемов, использованных когда-то автором при создании своих программ "Малый бизнес."
'В этом разделе вы унаете, как в Access программно выполнять задачи, далеко не очивидные с точки зрения документированных возможностей.
'Пунктирной линией разделены части одной задачи, т.е. декларация переменных, API методов и вызываемые для задачи процедуры или фукнкции
'Содержание
'Создание запроса
'Создание запроса в удаленной БД
'Установка ссылки на библиотеку
'Программное формирование многоколоночных комбобоксов
'Запуск другого сеанса Access
'Вычисление линкованной БД по связанной таблице
'Проверка на открытие формы
'Проверка приложения (MDB или MDE)
'Программный аналог функции DLookUP
'Вызов Help файла
'Запуск внешнего .exe файла
'Воспроизведение Wav файла
'Выполнение асинхронного запроса (исполняемого)
'Возвращение рекордсета
'Создание и выполнение запроса
Public dbsCurrent As DAO.Database
Sub СозданиеЗапросаПродажиПоПрихДокументу()
&nb
sp; On Error Resume Next
DoCmd.DeleteObject(acQuery, "ПродажиПоПрихДокументу")
strsql = "SELECT ОтборПриходногоДокумента.КодШапкиЗаказа, ПродажиНаОсновании([КодШапкиЗаказа],[КодМарки]) AS " _
& "[Sum_Кол-во1] " _
& "FROM [ОтборПриходногоДокумента];"
qdf = dbsCurrent.CreateQueryDef("ПродажиПоПрихДокументу", strsql)
qdf.Close()
End Sub
'Создание и выполнение запроса в удаленной БД
Function CreateSPT(SPTQueryName As String, SQLString As String, ConnectString As String, QueryDataBase As Database)
qdf = QueryDataBase.CreateQueryDef(SPTQueryName)
qdf.Connect = ConnectString
qdf.SQL = SQLString
qdf.Close()
End Function
'Установка ссылки на библиотеку
-------------------------
Библиотека = Left$(rst!DBSName, InStrRev(rst!DBSName, "\", , vbBinaryCompare) - 1) & "\MalbisOperations.mdb"
Call ReferenceFromFileLocal(Библиотека)
-------------------------
Function ReferenceFromFileLocal(strFilename As String) As Boolean
Dim ref As Reference
On Error GoTo Error_ReferenceFromFile
ref = References.AddFromFile(strFilename)
ReferenceFromFileLocal = True
Exit Function
Error_ReferenceFromFile:
If Err.Number = 32813 Then
ReferenceFromFileLocal = True
Else
ReferenceFromFileLocal = False
End If
End Function
'Программное формирование многоколоночных комбобоксов
'----------------
Dim rstСписокСтрок As Adodb.Recordset
'----------------
Set rstСписокСтрок = ИсточникСтрокВыбораЗаказовServer(Forms!Входная!КодНастройки, Forms!Входная!НачальнаяДата, _
Forms!Входная!КонечнаяДата, Forms!Документы!НачальнаяДата, Forms!Документ&
#1
099;!КонечнаяДата, Forms!Входная!КодПользователяБазы, КодФормы, _
КодПриложения, КодТипаФинансовогоДокумента, Фильтр, , Forms!Документы!КодШапкиЗаказа, _
Forms!Документы!ВыборРазделаПодраздела, КодОбъектаПривязки)
'----------------
Public Function ИсточникСтрокВыбораЗаказовServer(ByVal КодНастройки As Long, ByVal ВходнаяНачальнаяДата As Date, _
ByVal ВходнаяКонечнаяДата As Date, ByVal frmНачальнаяДата As Date, ByVal frmКонечнаяДата As Date, _
ByVal КодПользователяБазы As Long, ByVal КодФормы As Byte, ByVal КодПриложения As Long, _
ByVal КодТипаДокумента As Integer, ByVal Фильтр As String, Optional ВыборТипаДокумента As Long, _
Optional КодШапкиЗаказа As Long, Optional КодУровняПривязки As Long, _
Optional КодОбъектаПривязки As Long) As ADODB.Recordset
strServer = "SELECT DISTINCTROW ТШЗ.КодШапкиЗаказа, ПорядковыйНомер & "" от "" & ДатаРазмещения AS №, "
Select Case КодПриложения
Case 3
Select Case КодТипаДокумента
Case 25
strServer = strServer + _
"ТШЗ.НомерСметы AS [№ Сметы], ТШЗ.НаименованиеСметы AS [Наименование сметы], " _
& "CCur(CLng([ХозОперации].[Сумма]*100)/100) & [СокращенноеНаименование] AS Суммa, " _
& "Док
091;
ментСокращенно(ТШЗ.ИспользуетсяВДокументе) AS [К сводной смете], ТаблицаКлиенты.Организация AS Заказчик, " _
& "ПоискПодразделения([Подразделение]) AS Подрядчик " _
& "FROM ТаблицаВалюты INNER JOIN ((ТаблицаКлиенты INNER JOIN ТаблицаШапкаЗаказа as ТШЗ ON " _
& "ТаблицаКлиенты.КодЗаказчика = ТШЗ.КодЗаказчика) INNER JOIN (ТаблицаОперации INNER JOIN " _
& "ХозОперации ON ТаблицаОперации.КодОперации = ХозОперации.КодОперации) ON " _
& "ТШЗ.КодШапкиЗаказа = ХозОперации.КодШапкиЗаказа) ON ТаблицаВалюты.КодВалюты = ТШЗ.КодВалюты " & vbCrLf
End If
'.........................
End Select
'.........................
End Select
ИсточникСтрокВыбораЗаказовServer = rstExecConn(strServer)
End Function
'-------------------------
Public Function СписокДокументовТорговыйзал(fld As Control, id As Object, row As Object, col As Object, code As Object) As Object
Dim frm As Form
Dim КодФормы As Integer
Dim ReturnVal As Object
ReturnVal = Null
On Error Resume Next
Select Case code
Case acLBInitialize
If intRows >= 1 Then
avarRecords = rstСписокСтрок.GetRows(intRows)
ReturnVal = UBound(avarRecords, 2) + 1
End If
rstСписокСтрок.Close()
Case acLBOpen
&nbs
p; Ret
urnVal = Timer
Case acLBGetRowCount
ReturnVal = intRows
Case acLBGetColumnCount
ReturnVal = УстановкаКоличестваКолонок(3, КодПриложения, intКодТипаДокумента)
Case acLBGetColumnWidth
ReturnVal = УстановкаШириныКолонок(3, КодПриложения, intКодТипаДокумента, col)
Case acLBGetValue
ReturnVal = avarRecords(col, row)
Case acLBEnd
End Select
СписокДокументовТорговыйзал = ReturnVal
End Function
'----------------------
Function УстановкаКоличестваКолонок(КодФормы, КодПриложения, КодТипаДокумента) As Object
Select Case КодПриложения
Case 3
Select Case КодТипаДокумента
Case 25
УстановкаКоличестваКолонок = 8
Case 26
УстановкаКоличестваКолонок = 7
End Select
'....................
End Select
End Function
'------------------------------------
Function УстановкаШириныКолонок(КодФормы, КодПриложения, КодТипаДокумента, col) As Object
'1 см = 567 твип
Select КодПриложения
Case 3
Select Case КодТипаДокумента
Case 25
Select Case col
Case 0
УстановкаШириныКолонок = 0
yle="color: blue;">Case 1
УстановкаШириныКолонок = 1134
Case 2
УстановкаШириныКолонок = 1134
Case 3
УстановкаШириныКолонок = 4536
Case 4
УстановкаШириныКолонок = 850.5
Case 5
УстановкаШириныКолонок = 2268
Case 6
УстановкаШириныКолонок = 2268
Case 7
УстановкаШириныКолонок = 2268
End Select
'.........................
End Select
End Select
End Function
'Запуск другого сеанса Access
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
'------------------------------------------
Public Function RunAnotherApplication(ВызываемаяБаза As String, Функция As String, Optional Параметр1, _
Optional Параметр2, Optional Параметр3, Optional Параметр4, Optional ВызывающаяБаза As String) As Boolean
Dim sw As Long
On Error Resume Next
appAccess = CreateObject("Access.Application.9")
sw = ShowWindow(appAccess.hWndAccessApp, False)
appAccess.OpenCurrentDatabase(ВызываемаяБаза, False)
appAccess.Run(Функция, Параметр1, Параметр2, Параметр3, Параметр4, ВызывающаяБаза)
Err.Clear()
appAccess.Quit()
appAccess = Nothing
End Function
'Вычисление линкованной БД по связанной таблице
Public Function БазаТаблицы(ИмяТаблицы As String) As String
Dim tdf As TableDef
For Each tdf In dbs.TableDefs
If tdf.Name = ИмяТаблицы Then
БазаТаблицы = Right(tdf.Connect, Len(tdf.Connect) - Len(Left$(tdf.Connect, InStrRev(tdf.Connect, "\", , vbBinaryCompare))))
End If
Next tdf
End Function
'Проверка на открытие формы
Public Function IsLoaded(ByVal strFormName As String) As Boolean
Const conObjStateClosed = 0
Const conDesignView = 0
If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> conObjStateClosed Then
If Forms(strFormName).CurrentView <> conDesignView Then
IsLoaded = True
End If
End If
End Function
'Проверка приложения (MDB или MDE)
Public Function IsItMDE(dbs As Database) As Boolean
Dim strMDE As String
On Error Resume Next
strMDE = dbs.Properties("MDE")
If Err = 0 And strMDE = "T" Then
IsItMDE = True
Else
IsItMDE = False
End If
End Function
'Программный аналог функции DLookUP
Public Function ЗаменаDLookUP(ByVal БазаДанныхПоиска As Database, ByVal НаименованиеПоля As String, _
ByVal НаименованиеТаблицы As String, ByVal КритерийОтбора As String)
Dim rstЗаменаDLookUP Aspan> DAO.Recordset
strServer = "SELECT " & НаименованиеТаблицы & "." & НаименованиеПоля & " " _
& "FROM [" & НаименованиеТаблицы & "] " _
& "WHERE ((" & НаименованиеТаблицы & "." & КритерийОтбора & ")) " _
& "WITH OWNERACCESS OPTION;"
rstЗаменаDLookUP = БазаДанныхПоиска.OpenRecordset(strServer, dbOpenSnapshot, dbRunAsync)
If Not rstЗаменаDLookUP.BOF Then
rstЗаменаDLookUP.MoveFirst()
ЗаменаDLookUP = Nz(rstЗаменаDLookUP.Fields(0))
End If
rstЗаменаDLookUP.Close()
End Function
'Вызов Help файла
Const HH_DISPLAY_TOPIC = &H0
Const HH_HELP_CONTEXT = &HF
Public Declare Function HtmlHelp Lib "HHCtrl.ocx" Alias "HtmlHelpA" (ByVal hwndCaller As Long, ByVal pszFile As String, ByVal uCommand As Long, _
dwData As Any) As Long
'-----------------------------------------------
Public Function MalbisHelp(КодТемыСправки)
Dim rstСправка As New Adodb.Recordset
Dim ADOCon As New Adodb.Connection
ADOCon.ConnectionString = ClientConStr
ADOCon.Open()
If IsMissing(КодТемыСправки) Then
Call HtmlHelp(0, ТекущийКаталог(dbsCurrent.Name) & "\MalbisHelpSystem.chm", HH_DISPLAY_TOPIC, "ОПрограммеПолнаяВерсия.htm")
Else
rstСправка.CursorLocation = adUseClient
rstСправка.Open("ТемыСправкиПоПрограмме", ADOCon, adOpenKeyset, adLockBatchOptimistic)
rstСправка.Find("КодЗаписи=" & КодТемыСправки)
If Not rstСправка.BOF Then Call HtmlHelp(0, ТекущийКаталог(dbsCurrent.Name) & "\MalbisHelpSystem.chm", HH_DISPLAY_TOPIC, rstСправка!HelpFile)
rstСправка.Close()
End If
End Function
'Запу&#
1089;к &
#1074;нешнего .exe файла
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation _
As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd _
As Long) As Long
Global Const SW_SHOWNORMAL = 1
'---------------------------------
Public Function StartDoc(DocName As String)
On Error GoTo StartDoc_Error
StartDoc = ShellExecute(Application.hWndAccessApp, "Open", DocName, "", ТекущийКаталог(dbsCurrent.Name), SW_SHOWNORMAL)
Exit Function
StartDoc_Error:
MsgBox "Error: " & Err & " " & Error
End Function
'Воспроизведение Wav файла
Public Declare Function sndPlaySound Lib "WINMM.DLL" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, _
ByVal uFlags As Long) As Long
Public Const SND_SYNC = &H0
Public Const SND_ASYNC = &H1
Public Const SND_NODEFAULT = &H2
Public Const SND_LOOP = &H8
Public Const SND_NOSTOP = &H10
'--------------------------------------
Sub PlayWAV(SoundName$)
Dim wFlags%
Dim X%
If ОпределениеНастроекПриложения("ВключитьЗвук") = True Then
wFlags% = SND_ASYNC Or SND_NODEFAULT
X% = sndPlaySound(SoundName$, wFlags%)
End If
End Sub
'Выполнение асинхронного запроса (исполняемого)
Sub ExecuteServerConnection(ByVal StrSql As String)
conServer.Execute(StrSql)
Do While conServer.StillExecuting
DoEvents()
Loop
End Sub
'Возвращение рекордсета
Public Function rstExecConn(ByVal StrSql As St
ring) an style="color: blue;">As ADODB.Recordset
Dim Con As New ADODB.Connection
Con.Open(ADOConnectStr)
rstExecConn = New ADODB.Recordset
rstExecConn.CursorLocation = adUseClient
rstExecConn.Open(StrSql, Con, adOpenKeyset, adLockBatchOptimistic)
End Function