Ответить на сообщение
Вернуться к теме
Вы отвечаете на сообщение:
ник: Кабан конешно возможно вот, Рождественский Падараг, надёргаешь может чёнить себе
Option Compare Database Option Explicit Declare Function SQLDataSources Lib "odbc32.dll" (ByVal HENV As Long, _ ByVal Direction As Long, _ ByVal DSN As String, _ ByVal DSNMax As Integer, _ ByRef DSNLen As Integer, _ ByVal Description As String, _ ByVal DescriptionMax As Integer, _ ByRef DescriptionLen As Integer) As Integer Declare Function SQLAllocEnv Lib "odbc32.dll" (ByRef HENV As Long) As Integer Const SQL_SUCCESS As Long = 0 Const SQL_FETCH_NEXT As Long = 1 ' =========================================================================== ' Назначение модуля: ' Настройка связанных таблиц между базами данных ' Автор: Силыч ' Организация: ************** ' Дата начала разработки: 12.12.2006 ' Дата последней модификации: ' =========================================================================== ' =========================================================================== ' Назначение процедуры: ' Настройка связанных таблиц на удаленные базы данных ' Автор: Силыч ' Создание: 12.12.2006 ' Последняя модификация: ' =========================================================================== Public Function RefreshLinkTables(Optional SolveOrder& = 0) As Boolean Dim rstPath As ADODB.Recordset Dim spcRS As DAO.Recordset Dim stf As DAO.TableDef Dim dtf As DAO.TableDef Dim sbd As DAO.Database Dim dbd As DAO.Database Dim cbd As DAO.Database Dim strSQL$, strConnect$, sTbNam$, spcID&, spcCurrentID& On Error GoTo ErrRefreshLinkTables '-- В этой таблице содержится информация о настройках приложения. '-- Там, где bLink = True указываются пути к файлам баз данных Set cbd = CurrentDb If SolveOrder = 0 Then strSQL = "SELECT * FROM _tuneLinks order by iOrder" Else strSQL = "SELECT * FROM _tuneLinks WHERE sOrder=" & SolveOrder & " order by iOrder" End If Set rstPath = New ADODB.Recordset With rstPath .Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic Do Until .EOF '-- только для существующих источников и приемников If (Len(Dir(.Fields("srcPath"))) <> 0 And _ .Fields("lnkType") <> 3) Or _ ((.Fields("dstPath") <> "CurrentDB" And _ UCase(Right(.Fields("dstPath"), 3)) <> "MDB" And _ Len(Dir(.Fields("dstPath"))) <> 0)) Then '-- далее, в зависимости от типа настройки Select Case .Fields("lnkType") '-- Link ODBC---------------------------------------------------------- Case 3 If .Fields("dstPath") = "CurrentDB" Then Set dbd = cbd Else Set dbd = DBEngine.Workspaces(0).OpenDatabase(.Fields("dstPath")) End If '-- удалить связь On Error Resume Next dbd.TableDefs.Delete .Fields("lnkNam") dbd.TableDefs.Refresh On Error GoTo ErrRefreshLinkTables '-- создать по новой, если bLink<>0 If .Fields("bLink") <> 0 And .Fields("aLink") <> 0 Then Set dtf = dbd.CreateTableDef(.Fields("lnkNam")) '--"ODBC;DSN=SERVER.XXXYYY;UID=UserID;PWD=PASSWORD;DATABASE=DBNAME;AutoTranslate=No" dtf.Connect = .Fields("srcPath") dtf.SourceTableName = .Fields("objNam") 'добавляем таблицу в семейство TableDefs dbd.TableDefs.Append dtf dbd.TableDefs.Refresh End If '-- Link TXT ---------------------------------------------------------- Case 2 sTbNam = GetShortFileName(.Fields("srcPath")) Set dbd = DBEngine.Workspaces(0).OpenDatabase(.Fields("dstPath")) '-- разберемся со спецификациями spcID = 0 Set spcRS = cbd.OpenRecordset("SELECT * FROM MSysIMEXSpecs " & _ "WHERE SpecName='" & Nz(.Fields("spcNam"), "") & "'") If Not spcRS.EOF Then spcCurrentID = spcRS.Fields("SpecID") spcRS.Close Set spcRS = dbd.OpenRecordset("SELECT * FROM MSysIMEXSpecs " & _ "WHERE SpecName='" & Nz(.Fields("spcNam"), "") & "'") If Not spcRS.EOF Then spcID = spcRS.Fields("SpecID") If spcID <> 0 Then '-- удалим колонки dbd.Execute "DELETE * FROM MSysIMEXColumns WHERE SpecID=" & spcID, dbFailOnError '-- удалим пецификации dbd.Execute "DELETE * FROM MSysIMEXSpecs WHERE SpecID=" & spcID, dbFailOnError spcID = 0 End If '-- залить по новой cbd.Execute "INSERT INTO MSysIMEXSpecs (DateDelim,DateFourDigitYear," & _ "DateLeadingZeros,DateOrder,DecimalPoint,FieldSeparator," & _ "FileType,SpecName,SpecType,StartRow,TimeDelim) " & _ "IN '" & .Fields("dstPath") & "' " & _ "SELECT DateDelim,DateFourDigitYear," & _ "DateLeadingZeros,DateOrder,DecimalPoint,FieldSeparator," & _ "FileType,SpecName,SpecType,StartRow,TimeDelim " & _ "FROM MSysIMEXSpecs " & _ "WHERE SpecName='" & Nz(.Fields("spcNam"), "") & "'", dbFailOnError '-- получить новый spcID,если все удачно Set spcRS = dbd.OpenRecordset("SELECT * FROM MSysIMEXSpecs WHERE SpecName='" & Nz(.Fields("spcNam"), "") & "'") If Not spcRS.EOF Then spcID = spcRS.Fields("SpecID") '-- нет такой спецификации или не удалось создать If spcID = 0 Then MsgBox "Ошибка при обновлении связей таблиц:" & vbCrLf & "Не удалось создать спецификацию" & vbCrLf & _ "[" & .Fields("spcNam") & "]" & vbCrLf & _ "Обратитесь к разработчикам.", vbExclamation + vbOKOnly, "Обновление связей таблиц" GoTo Exit1 Else cbd.Execute "INSERT INTO MSysIMEXColumns (SpecID,Attributes," & _ "DataType,FieldName,IndexType,SkipColumn,Start,Width) " & _ "IN '" & .Fields("dstPath") & "' " & _ "SELECT " & spcID & " as SpecID,Attributes," & _ "DataType,FieldName,IndexType,SkipColumn,Start,Width " & _ "FROM MSysIMEXColumns " & _ "WHERE SpecID=" & spcCurrentID, dbFailOnError End If '-- по любасу удалить связь нах '-- имеем полное моральное право написать в данном случае On Error Resume Next dbd.TableDefs.Delete .Fields("lnkNam") dbd.TableDefs.Refresh On Error GoTo ErrRefreshLinkTables '-- создать по новой, если bLink<>0 If .Fields("bLink") <> 0 And .Fields("aLink") <> 0 Then Set dtf = dbd.CreateTableDef(.Fields("lnkNam")) dtf.Connect = "Text;DSN=" & .Fields("spcNam") & ";FMT=" & .Fields("spcFMT") & _ ";HDR=NO;IMEX=2;CharacterSet=" & .Fields("spc4set") & ";" & _ "DATABASE=" & Left(.Fields("srcPath"), Len(.Fields("srcPath")) - Len(sTbNam) - 1) dtf.SourceTableName = sTbNam 'добавляем таблицу в семейство TableDefs dbd.TableDefs.Append dtf dbd.TableDefs.Refresh End If '-- Link Excel ---------------------------------------------------------- Case 1 '-- создать по новой, если bLink<>0 And .Fields("aLink") If .Fields("bLink") <> 0 And .Fields("aLink") <> 0 Then sTbNam = GetShortFileName(.Fields("srcPath")) If .Fields("dstPath") = "CurrentDB" Then Set dbd = cbd Else Set dbd = DBEngine.Workspaces(0).OpenDatabase(.Fields("dstPath")) End If '-- удалить связь On Error Resume Next dbd.TableDefs.Delete .Fields("lnkNam") dbd.TableDefs.Refresh On Error GoTo ErrRefreshLinkTables '-- создать по новой, если bLink<>0 If .Fields("bLink") <> 0 And .Fields("aLink") <> 0 Then Set dtf = dbd.CreateTableDef(.Fields("lnkNam")) dtf.Connect = "Excel 5.0;DATABASE=" & .Fields("srcPath") dtf.SourceTableName = Trim(.Fields("objNam")) & "$" 'добавляем таблицу в семейство TableDefs dbd.TableDefs.Append dtf dbd.TableDefs.Refresh 'Set sbd = DBEngine.Workspaces(0).OpenDatabase(.Fields("srcPath")) End If End If '-- Link Access ---------------------------------------------------------- Case 0 sTbNam = GetShortFileName(.Fields("srcPath")) If .Fields("dstPath") = "CurrentDB" Then Set dbd = cbd Else Set dbd = DBEngine.Workspaces(0).OpenDatabase(.Fields("dstPath")) End If '-- удалить связь On Error Resume Next dbd.TableDefs.Delete .Fields("lnkNam") dbd.TableDefs.Refresh On Error GoTo ErrRefreshLinkTables '-- создать по новой, если bLink<>0 If .Fields("bLink") <> 0 And .Fields("aLink") <> 0 Then Set dtf = dbd.CreateTableDef(.Fields("lnkNam")) dtf.Connect = ";DATABASE=" & .Fields("srcPath") dtf.SourceTableName = .Fields("objNam") 'добавляем таблицу в семейство TableDefs dbd.TableDefs.Append dtf dbd.TableDefs.Refresh End If End Select Set sbd = Nothing: Set dbd = Nothing End If .MoveNext Loop End With RefreshLinkTables = True Exit1: rstPath.Close: Set rstPath = Nothing '-- Освобождение объектов Set stf = Nothing: Set dtf = Nothing Set sbd = Nothing: Set dbd = Nothing: Set cbd = Nothing Exit Function '-- Обработка ошибки подключения ErrRefreshLinkTables: MsgBox "Ошибка при обновлении связей таблиц:" & vbCrLf & Err.Description, _ vbExclamation + vbOKOnly, "Обновление связей таблиц" RefreshLinkTables = False GoTo Exit1 End Function ' Function ODBC_GetListDSN() Dim i As Integer Dim sDSNItem As String * 1024 Dim sDRVItem As String * 1024 Dim sDSN As String Dim sDRV As String Dim iDSNLen As Integer Dim iDRVLen As Integer Dim lHenv As Long On Error Resume Next 'получаем DSN's If SQLAllocEnv(lHenv) <> -1 Then Do Until i <> SQL_SUCCESS sDSNItem = Space$(1024) sDRVItem = Space$(1024) i = SQLDataSources(lHenv, SQL_FETCH_NEXT, sDSNItem, 1024, _ iDSNLen, sDRVItem, 1024, iDRVLen) sDSN = Left$(sDSNItem, iDSNLen) sDRV = Left$(sDRVItem, iDRVLen) If sDSN <> Space(iDSNLen) Then Debug.Print sDSN, sDRV End If Loop End If End Function Function Translit_TO_ODBC(Source$) As String Dim i%, R$ For i = 1 To Len(Source) Select Case Mid(Source, i, 1) '------------------------------------------------------------------------------------- Case "А" R = R + "A" Case "Б" R = R + "A" Case "В" R = R + "A" Case "Г" R = R + "A" Case "Д" R = R + "A" Case "Е" R = R + "A" Case "Ж" R = R + "?" Case "З" R = R + "C" Case "И" R = R + "E" Case "Й" R = R + "E" Case "К" R = R + "E" Case "Л" R = R + "E" Case "М" R = R + "I" Case "Н" R = R + "I" Case "О" R = R + "I" Case "П" R = R + "I" Case "Р" R = R + "?" Case "С" R = R + "N" Case "Т" R = R + "O" Case "У" R = R + "O" Case "Ф" R = R + "O" Case "Х" R = R + "O" Case "Ц" R = R + "O" Case "Ч" R = R + "?" Case "Ш" R = R + "O" Case "Щ" R = R + "U" Case "Ъ" R = R + "U" Case "Ы" R = R + "U" Case "Ь" R = R + "U" Case "Э" R = R + "Y" Case "Ю" R = R + "?" Case "Я" R = R + "?" Case "а" R = R + "a" Case "б" R = R + "a" Case "в" R = R + "a" Case "г" R = R + "a" Case "д" R = R + "a" Case "е" R = R + "a" Case "ж" R = R + "?" Case "з" R = R + "c" Case "и" R = R + "e" Case "й" R = R + "e" Case "к" R = R + "e" Case "л" R = R + "e" Case "м" R = R + "i" Case "н" R = R + "i" Case "о" R = R + "i" Case "п" R = R + "i" Case "р" R = R + "?" Case "с" R = R + "n" Case "т" R = R + "o" Case "у" R = R + "o" Case "ф" R = R + "o" Case "х" R = R + "o" Case "ц" R = R + "o" Case "ч" R = R + "?" Case "ш" R = R + "o" Case "щ" R = R + "u" Case "ъ" R = R + "u" Case "ы" R = R + "u" Case "ь" R = R + "u" Case "э" R = R + "y" Case "ю" R = R + "?" Case "я" R = R + "y" Case "І" R = R + "?" Case "і" R = R + "?" Case "Ї" R = R + "?" Case "ї" R = R + "?" Case "є" R = R + "?" Case "Є" R = R + "?" Case "Ё" R = R + "?" Case "ё" R = R + "?" Case Else R = R + Mid(Source$, i%, 1) End Select Next Translit_TO_ODBC = R$ End Function Function Translit_From_ODBC(Source$) As String Dim i%, R$ For i = 1 To Len(Source) Select Case Mid(Source, i, 1) Case "L" R = R + "А" Case "+" R = R + "Б" Case "T" R = R + "В" Case "+" R = R + "Г" Case "-" R = R + "Д" Case "+" R = R + "Е" Case "a" R = R + "Ж" Case "A" R = R + "З" Case "L" R = R + "И" Case "г" R = R + "Й" Case "¦" R = R + "К" Case "T" R = R + "Л" Case "¦" R = R + "М" Case "=" R = R + "Н" Case "+" R = R + "О" Case "¤" R = R + "П" Case "?" R = R + "Р" Case "?" R = R + "С" Case "E" R = R + "Т" Case "E" R = R + "У" Case "E" R = R + "Ф" Case "?" R = R + "Х" Case "I" R = R + "Ц" Case "I" R = R + "Ч" Case "I" R = R + "Ш" Case "-" R = R + "Щ" Case "-" R = R + "Ъ" Case "-" R = R + "Ы" Case "-" R = R + "Ь" Case "¦" R = R + "Э" Case "I" R = R + "Ю" Case "-" R = R + "Я" Case "O" R = R + "а" Case "?" R = R + "б" Case "O" R = R + "в" Case "O" R = R + "г" Case "o" R = R + "д" Case "O" R = R + "е" Case "µ" R = R + "ж" Case "?" R = R + "з" Case "?" R = R + "и" Case "U" R = R + "й" Case "U" R = R + "к" Case "U" R = R + "л" Case "y" R = R + "м" Case "Y" R = R + "н" Case "?" R = R + "о" Case "?" R = R + "п" Case "" R = R + "р" Case "±" R = R + "с" Case "?" R = R + "т" Case "?" R = R + "у" Case "¶" R = R + "ф" Case "§" R = R + "х" Case "?" R = R + "ц" Case "?" R = R + "ч" Case "°" R = R + "ш" Case "?" R = R + "щ" Case "·" R = R + "ъ" Case "?" R = R + "ы" Case "?" R = R + "ь" Case "?" R = R + "э" Case "¦" R = R + "ю" Case " " R = R + "я" Case "-" R = R + "І" Case "¦" R = R + "і" Case "»" R = R + "Ї" Case "¬" R = R + "ї" Case "¬" R = R + "Є" Case "¦" R = R + "є" Case "?" R = R + "ё" Case "©" R = R + "ё" Case Else R = R + Mid(Source$, i%, 1) End Select Next Translit_From_ODBC = R End Function
tpAdm bLink aLink sOrder iOrder srcPath dstPath objNam lnkNam lnkType spcNam spcFMT spc4set SYS ИСТИНА ИСТИНА 1 1 C:\OTCH\TXT\#ss-12345.txt C:\gs200607.mdb nbu Файл TXT spec_NBU Fixed 866 SYS ИСТИНА ИСТИНА 1 2 L:\cort.txt C:\gs200607.mdb ocb Файл TXT spec_OCB Delimited 866 SYS ЛОЖЬ ЛОЖЬ 4 12 ODBC;DSN=SERVER.XXXYYYY;UID=UserID;PWD=PASSWORD;DATABASE=DBNAME;AutoTranslate=No CurrentDB dbo.TableName srv_TableName ODBC SYS ИСТИНА ИСТИНА 2 13 M:\ОБЩИЕ\gs200607.mdb CurrentDB cmp4 work_cmp4 Таблица Access
Ваше имя:
Пароль:
Сообщение:
Прикрепить:
Для вставки смайлов в текст щелкните по значку.