Зарегистрировано: 318




Помощь  Карта сайта

О чем пишут?

Илья Ильф, Евгений Петров. Одноэтажная Америка

Илья Ильф, Евгений Петров. Одноэтажная Америка * Часть первая. ИЗ ОКНА ДВАДЦАТЬ СЕДЬМОГО ЭТАЖА * Глава первая. "НОРМАНДИЯ" В девять часов из Парижа выходит специальный поезд, отвозящий в Гавр пассажиров "Нормандии". Поезд идет без остановок и через три часа вкатывается в здание гаврского морского ..
Дальше..

Я так вижу!

Вид из кабинета.jpg

Вид из кабинета.jpg



Тексты. Прозариум

Тексты на сайте могут публиковаться как в составе книг, по которым они "разложены", так и по отдельности. Тексты можно публиковать на странице их владельца, в блогах, клубах или рубриках сайта, а так же в виде статей и объявлений. Вы можете публиковать на сайте не только собственные тексты, но и те, которыми хотите поделиться с читателями, соблюдая авторские права их владельцев.
Prozarium CMS | Реклама, сотрудничество | Разработка, продажа сайтов

Для добавления вашего собственного контента, а также для загрузки текстов целиком, загрузки текстов без разбиения на страницы, загрузки книг без разбиения на тексты, необходима авторизация. Если вы зарегистрированы на сайте, введите свой логин и пароль. Если нет, пожалуйста, пройдите регистрацию



Опубликовано в: Клуб: MS Access
<--Программирование
<--IT Информационные технологии
<--Бизнес по сферам деятельности

0





НЕКОТОРЫЕ ПРИЕМЫ ПРОГРАММИРОВАНИЯ В ACCESS
/pterodactilus vulgaris/
13.09.2012


'   Для тех, кому интересно покопаться в 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

 



2001
Е.Трифонов