K
kfschaefer
Ihave written code to transfer database tables from Oracle, however, when I
use the converted code from a macro - it requires a pop for login info.
I need to eliminate this popup and have the process run automatically at
night.
here is my current code - Please feel free to make suggestions.
Yes the password and user id are identical - for ease of use - since you
can't collect the current user id and password via vba.
Private Declare Function apiGetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Function fOSUserName() As String
' Returns the network login name
Dim lngLen As Long, lngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngX = apiGetUserName(strUserName, lngLen)
If (lngX > 0) Then
fOSUserName = Left$(strUserName, lngLen - 1)
Else
fOSUserName = vbNullString
End If
End Function
'******************** Code End **************************
'------------------------------------------------------------
' Get_Latest_Metrica_Data_From_MTR2
' Will automatically update/replace the data weekly -
' to be run @ 3am evert Wednesday
'------------------------------------------------------------
Function Get_Latest_Metrica_Data_From_MTR2()
On Error GoTo Get_Latest_Metrica_Data_From_MTR2_Err
Dim nTable, nDev As String
Dim db As Database
Dim rs As Recordset
Dim strSql As String
Dim cn As ADODB.Connection
Dim strConnection As String
Dim i As Integer
SetWarnings = False
strSql = "SELECT Name" & _
" FROM tblListActiveImportTables"
Set db = currentdb() 'Use the current database
Set rs = db.OpenRecordset(strSql) 'actually open the recordset
i = 0
Do Until rs.EOF = True
i = i + 1
nTable = rs.Fields("Name")
nDev = Replace(Left(rs.Fields("Name"), InStr(rs.Fields("Name"), "_")),
"_", ".") & Mid(rs.Fields("Name"), InStr(rs.Fields("Name"), "_") + 1)
On Error Resume Next
If IsObject(currentdb.TableDefs(nTable)) Then
DoCmd.DeleteObject acTable, nTable
End If
strConnection = "ODBC;DSN=MTR2;UID=" & fOSUserName & ";PWD=" &
fOSUserName & ";DATABASE=MTR2"
'Create a new ADO Connection object
Set cn = New ADODB.Connection
With cn
.Provider = "MSDASQL"
.Properties("Data Source").Value = strConnection
.Open
End With
DoCmd.TransferDatabase acImport, strConnection, Table = " & Chr(34) & ndev &
Chr(34) & ", acTable, " & Chr(34) & nDev & Chr(34) & ", " & Chr(34) & nTable
& Chr(34) & """"", False
'DoCmd.TransferDatabase acImport, "ODBC Database", _
"ODBC;DSN=MTR2;UID=" & fOSUserName & ";PWD=" & fOSUserName &
";LANGUAGE=us_english;" _
& "DATABASE=MTR2", acTable, Table=" & Chr(34) & ndev & Chr(34) & "," &
Chr(34) & ndev & Chr(34) & ", " & Chr(34) & nTable & Chr(34) & "", True"
DoCmd.TransferDatabase acImport, "ODBC", "ODBC;DSN=MTR2;UID=" & fOSUserName
& ";", _
"PWD=" & fOSUserName & "; & DBQ=MTR2
;DBA=W;APA=T;EXC=F;FEN=T;QTO=T;FRC=10;", _
"FDL=10;LOB=T;RST=T;GDE=F;FRL=F;BAM=IfAllSuccessful;MTS=F;MDI=F;CSR=F;FWC=F;", _
"PFC=10;TLO=0;;TABLE=" & Chr(34) & nDev & Chr(34) & ", acTable,", _
" " & Chr(34) & nDev & Chr(34) & "," & Chr(34) & nTable & Chr(34) &
", False"
' DoCmd.TransferDatabase acImport, "ODBC",
"ODBC;DSN=MTR2;UID=JGONZALEZ;DBQ=MTR2
;DBA=W;APA=T;EXC=F;FEN=T;QTO=T;FRC=10;FDL=10;LOB=T;RST=T;GDE=F;FRL=F;BAM=IfAllSuccessful;MTS=F;MDI=F;CSR=F;FWC=F;PFC=10;TLO=0;;TABLE=APPUSER.MSCTR_DY",
acTable, "APPUSER.MSCTR_DY", "APPUSER_MSCTR_DY", False
rs.MoveNext
Loop
rs.Close
Get_Latest_Metrica_Data_From_MTR2_Exit:
Exit Function
Get_Latest_Metrica_Data_From_MTR2_Err:
MsgBox Error$
Resume Get_Latest_Metrica_Data_From_MTR2_Exit
End Function
As you can see I have many different version of transferdatabase in attempt
to prevent the popup.
use the converted code from a macro - it requires a pop for login info.
I need to eliminate this popup and have the process run automatically at
night.
here is my current code - Please feel free to make suggestions.
Yes the password and user id are identical - for ease of use - since you
can't collect the current user id and password via vba.
Private Declare Function apiGetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Function fOSUserName() As String
' Returns the network login name
Dim lngLen As Long, lngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngX = apiGetUserName(strUserName, lngLen)
If (lngX > 0) Then
fOSUserName = Left$(strUserName, lngLen - 1)
Else
fOSUserName = vbNullString
End If
End Function
'******************** Code End **************************
'------------------------------------------------------------
' Get_Latest_Metrica_Data_From_MTR2
' Will automatically update/replace the data weekly -
' to be run @ 3am evert Wednesday
'------------------------------------------------------------
Function Get_Latest_Metrica_Data_From_MTR2()
On Error GoTo Get_Latest_Metrica_Data_From_MTR2_Err
Dim nTable, nDev As String
Dim db As Database
Dim rs As Recordset
Dim strSql As String
Dim cn As ADODB.Connection
Dim strConnection As String
Dim i As Integer
SetWarnings = False
strSql = "SELECT Name" & _
" FROM tblListActiveImportTables"
Set db = currentdb() 'Use the current database
Set rs = db.OpenRecordset(strSql) 'actually open the recordset
i = 0
Do Until rs.EOF = True
i = i + 1
nTable = rs.Fields("Name")
nDev = Replace(Left(rs.Fields("Name"), InStr(rs.Fields("Name"), "_")),
"_", ".") & Mid(rs.Fields("Name"), InStr(rs.Fields("Name"), "_") + 1)
On Error Resume Next
If IsObject(currentdb.TableDefs(nTable)) Then
DoCmd.DeleteObject acTable, nTable
End If
strConnection = "ODBC;DSN=MTR2;UID=" & fOSUserName & ";PWD=" &
fOSUserName & ";DATABASE=MTR2"
'Create a new ADO Connection object
Set cn = New ADODB.Connection
With cn
.Provider = "MSDASQL"
.Properties("Data Source").Value = strConnection
.Open
End With
DoCmd.TransferDatabase acImport, strConnection, Table = " & Chr(34) & ndev &
Chr(34) & ", acTable, " & Chr(34) & nDev & Chr(34) & ", " & Chr(34) & nTable
& Chr(34) & """"", False
'DoCmd.TransferDatabase acImport, "ODBC Database", _
"ODBC;DSN=MTR2;UID=" & fOSUserName & ";PWD=" & fOSUserName &
";LANGUAGE=us_english;" _
& "DATABASE=MTR2", acTable, Table=" & Chr(34) & ndev & Chr(34) & "," &
Chr(34) & ndev & Chr(34) & ", " & Chr(34) & nTable & Chr(34) & "", True"
DoCmd.TransferDatabase acImport, "ODBC", "ODBC;DSN=MTR2;UID=" & fOSUserName
& ";", _
"PWD=" & fOSUserName & "; & DBQ=MTR2
;DBA=W;APA=T;EXC=F;FEN=T;QTO=T;FRC=10;", _
"FDL=10;LOB=T;RST=T;GDE=F;FRL=F;BAM=IfAllSuccessful;MTS=F;MDI=F;CSR=F;FWC=F;", _
"PFC=10;TLO=0;;TABLE=" & Chr(34) & nDev & Chr(34) & ", acTable,", _
" " & Chr(34) & nDev & Chr(34) & "," & Chr(34) & nTable & Chr(34) &
", False"
' DoCmd.TransferDatabase acImport, "ODBC",
"ODBC;DSN=MTR2;UID=JGONZALEZ;DBQ=MTR2
;DBA=W;APA=T;EXC=F;FEN=T;QTO=T;FRC=10;FDL=10;LOB=T;RST=T;GDE=F;FRL=F;BAM=IfAllSuccessful;MTS=F;MDI=F;CSR=F;FWC=F;PFC=10;TLO=0;;TABLE=APPUSER.MSCTR_DY",
acTable, "APPUSER.MSCTR_DY", "APPUSER_MSCTR_DY", False
rs.MoveNext
Loop
rs.Close
Get_Latest_Metrica_Data_From_MTR2_Exit:
Exit Function
Get_Latest_Metrica_Data_From_MTR2_Err:
MsgBox Error$
Resume Get_Latest_Metrica_Data_From_MTR2_Exit
End Function
As you can see I have many different version of transferdatabase in attempt
to prevent the popup.