Option
Explicit
Sub
StücklisteJoinAbfrage()
Dim
con
As
Object
Dim
con2
As
Object
Dim
rs
As
Object
Dim
AccessFile
As
String
Dim
AccessPfad2
As
String
Dim
AccessFile2
As
String
Dim
strTable
As
String
Dim
strTable2
As
String
Dim
AccessPassword
As
String
Dim
SQL
As
String
Dim
i
As
Integer
Application.ScreenUpdating =
False
AccessFile =
"C:\Users\FE3\Desktop\SEP-Dateien\Ansicht-Netze_BW.sep"
AccessFile2 =
"C:\Users\FE3\Desktop\Symbols\Types.ses"
AccessPfad2 = "C:\Users\FE3\Desktop\Symbols\"
AccessPassword =
"SECRET"
strTable =
"AllComponentTypesCount"
strTable2 =
"Type"
On
Error
Resume
Next
Set
con = CreateObject(
"ADODB.connection"
)
Set
con2 = CreateObject(
"ADODB.connection"
)
If
Err.Number <> 0
Then
MsgBox
"Connection was not created!"
, vbCritical,
"Connection Error"
Exit
Sub
End
If
On
Error
GoTo
0
con.Open
"Provider=Microsoft.Jet.OLEDB.4.0;"
& _
"Data Source="
& AccessFile &
";"
& _
"Jet OLEDB:Database Password="
& AccessPassword
con2.Open
"Provider=Microsoft.Jet.OLEDB.4.0;"
& _
"Data Source="
& AccessFile2 &
";"
& _
"Jet OLEDB:Database Password="
& AccessPassword
SQL =
"SELECT * "
_
&
"FROM Ansicht-Netze_BW.sep AllComponentTypesCount AS 'Products' "
_
&
"LEFT JOIN [text;database="
& AccessPfad2 &
"].Types.ses AS Types "
_
&
"ON AllComponentTypesCount.160040 = Types.Type"
On
Error
Resume
Next
Set
rs = CreateObject(
"ADODB.Recordset"
)
If
Err.Number <> 0
Then
Set
rs =
Nothing
Set
con =
Nothing
MsgBox
"Recordset wurde nicht erstellt!"
, vbCritical,
"Recordset Error"
Exit
Sub
End
If
On
Error
GoTo
0
rs.CursorLocation = 3
rs.CursorType = 1
rs.Open SQL, con
If
rs.EOF
And
rs.BOF
Then
rs.Close
con.Close
Set
rs =
Nothing
Set
con =
Nothing
Set
con2 =
Nothing
Application.ScreenUpdating =
True
MsgBox
"Keine Aufzeichnungen im Recordset!"
, vbCritical,
"No Records"
Exit
Sub
End
If
For
i = 0
To
rs.Fields.count - 1
Sheets(
"Stückliste"
).Cells(1, i + 1) = rs.Fields(i).Name
Next
i
Sheets(
"Stückliste"
).Range(
"A2"
).CopyFromRecordset rs
rs.Close
con.Close
Set
rs =
Nothing
Set
con =
Nothing
Sheets(
"Stückliste"
).Columns(
"A:E"
).AutoFit
Application.ScreenUpdating =
True
MsgBox
"Produktliste wurde erfolgreich aus '"
& strTable &
"' generiert!"
, vbInformation,
"Done"
End
Sub