|
Доброго времени суток, Посетитель!
|
|
|
|
|
|
|
|
|
вид форума:
|
|
|
| |
|
|
| | все кроме модулей легко решаемо через FSO и DAO, про модули нужно смотреть не помню уже, возможно что придется открывать базу как текущую (при этом может сработать код или открыться форма) | |
| |
| |
| |
 31 Кб. |
|
| | конешно возможно 
вот, Рождественский Падараг, надёргаешь может чёнить себе 
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
|
структура таблицы _tuneLinks (см. аттач)
пример данных
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
|
| |
| |
| |
| |
|
|
| | Серега!!!
а это зачем?
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 | |
| |
| |
| |
|
|
| | не помню :) давно было
вроде вставляет спецификацию или чето там в другую бд из текущей
а что? | |
| |
| |
| |
|
|
| | Серега
спасибо, буду пробывать.
с модулями бы наколупать  | |
| |
| |
| |
|
|
| | Это не поможет? Сам не пробовал.
Option Compare Database
Option Explicit
Public Sub test()
FRDB "d:\~home~\desktop\db1.mdb", "172.20.1.7", "11.111.11.1"
FRDB "d:\~home~\desktop\db1.mdb", "172.20.1.7", "11.111.11.1"
MsgBox "Усе"
End Sub
Public Function FRDB(MdbFullName As String, MyServerOld As String, MyServerNew As String)
Dim cmd As String
Dim App As Access.Application
cmd = """" & SysCmd(acSysCmdAccessDir) & "msaccess.exe"""
cmd = cmd & " """ & MdbFullName & """"
Shell cmd, vbHide
Set App = GetObject(MdbFullName)
AllProcsFindAndReplace App, MyServerOld, MyServerNew
App.Quit
End Function
Public Function AllProcsFindAndReplace(ByRef App As Access.Application, MyServerOld As String, MyServerNew As String)
Dim oVBComponent As Object, mdl As Object
For Each oVBComponent In App.VBE.ActiveVBProject.VBComponents
Set mdl = oVBComponent.CodeModule
FindAndReplace App, mdl.Name, MyServerOld, MyServerNew
Next
End Function
Function FindAndReplace(App As Access.Application, strModuleName As String, strSearchText As String, strNewText As String) As Boolean
Dim mdl As Module
Dim lngSLine As Long, lngSCol As Long
Dim lngELine As Long, lngECol As Long
Dim strLine As String, strNewLine As String
Dim intChr As Integer, intBefore As Integer, intAfter As Integer
Dim strLeft As String, strRight As String
' Open module.
App.DoCmd.OpenModule strModuleName
' Return reference to Module object.
Set mdl = App.Modules(strModuleName)
' Search for string.
If mdl.Find(strSearchText, lngSLine, lngSCol, lngELine, _
lngECol) Then
' Store text of line containing string.
strLine = mdl.Lines(lngSLine, Abs(lngELine - lngSLine) + 1)
' Determine length of line.
intChr = Len(strLine)
' Determine number of characters preceding search text.
intBefore = lngSCol - 1
' Determine number of characters following search text.
intAfter = intChr - CInt(lngECol - 1)
' Store characters to left of search text.
strLeft = Left$(strLine, intBefore)
' Store characters to right of search text.
strRight = Right$(strLine, intAfter)
' Construct string with replacement text.
strNewLine = strLeft & strNewText & strRight
' Replace original line.
mdl.ReplaceLine lngSLine, strNewLine
FindAndReplace = True
Else
'MsgBox "Text not found."
FindAndReplace = False
End If
Exit_FindAndReplace:
Exit Function
Error_FindAndReplace:
MsgBox Err & ": " & Err.Description
FindAndReplace = False
Resume Exit_FindAndReplace
End Function
|
| |
| |
| |
| |
|
|
| | С модулями видимо придется делать GetObject("C:\file.mdb")
а дальше в этом application VBE.VBProject и т.д.
Сергей Гаврилов появится, мож он что поинтереснее предложит | |
| |
| | |
|
HiProg.com - Технологии программирования
|
. Перелинковывать таблицы в каждой базе скриптом не очень хочется, а уж тем более вручную.
