ACCESS FEED: RE: [belajar-access] Query Union Error ketika tabel terkoneksi ke MySql

Minggu, 31 Juli 2016

RE: [belajar-access] Query Union Error ketika tabel terkoneksi ke MySql

Begini...,

1. Buat modul koneksi dan nama komputer, karena akan di pakai di hampir semua form. Nama komputer digunakan untuk nama tabel biar unik antar masing-masing user

Ini scriptnya:

Option Explicit
Public conn As New ADODB.Connection 'deklarasi koneksi

Private Const MAX_COMPUTERNAME As Long = 15
Private Declare Function GetComputerName Lib "kernel32" _
Alias "GetComputerNameA" _
(ByVal lpBuffer As String, _
nSize As Long) As Long

Private Function TrimNull(item As String)

'return string before the terminating null
Dim pos As Integer

pos = InStr(item, Chr$(0))

If pos Then
TrimNull = Left$(item, pos - 1)
Else
TrimNull = item
End If

End Function

Function KOM()
'untuk membuat tabel berdasarkan nama komputer

Dim tas As String

'pre-load the text boxes with
'the local computer name for testing
tas = Space$(MAX_COMPUTERNAME + 1)
Call GetComputerName(tas, Len(tas))

KOM = TrimNull(tas)
If KOM Like "*-*" Then
KOM = Replace(KOM, "-", "_")
End If
End Function

Public Function connToDB(ServerName As String, _
UserName As String, userPass As Variant, _
dbPath As String, dbName As String)

Dim strCon As String

On Error GoTo errHandle
'sesuaikan driver mysqlnya, ada yang pakai 3.51
strCon = "DRIVER={MySQL ODBC 5.1 Driver};SERVER=" _
& ServerName & ";DATABASE=" & dbName & ";" & _
"UID=" & UserName & ";PWD=" & userPass & ";OPTION=16426"

Set conn = New ADODB.Connection
conn.Open strCon

Exit Function

errHandle:
MsgBox "SERVER SEDANG TIDAK AKTIF", , "NON AKTIF"
conn.Close
Set conn = Nothing
End Function

Public Function EscapeQuotes(s) As String

If s = "" Then
EscapeQuotes = ""
ElseIf Left(s, 1) = "'" Then
EscapeQuotes = "''" & EscapeQuotes(Mid(s, 2))
Else

EscapeQuotes = Left(s, 1) & EscapeQuotes(Mid(s, 2))
End If

End Function

Function hp_tb(n_tb)
Dim rbs As Recordset
Dim db As DAO.Database
'untuk menghapus tabel Access temporer
Set rbs = CurrentDb.OpenRecordset("SELECT MSysObjects.Name" _
& " FROM MSysObjects WHERE MSysObjects.Type= 1 And MSysObjects.Flags=0" _
& " and MSysObjects.Name='" & n_tb & "'") 'melihat nama tabel n_tb
If Not rbs.EOF Then 'bila ada record
Set db = CurrentDb 'menetapkan bahwa db adalah database ini
db.TableDefs.Delete n_tb 'hapus tabel
'menghilangkan dari memory komputer
db.Close
Set db = Nothing
End If
'menghilangkan dari memory komputer
rbs.Close
Set rbs = Nothing

End Function

Function KONEKSI()
'connToDB txtServer, txtUID, txtPWD, 3306, txtDb
connToDB "localhost", "root", "admin", 3306, "Nama_database"
End Function

2. Kita mulai bermain di form. Misal nama comboBoxnya contoh.Propertinya:
Control Source ==> kosongkan
Row Source Type ==> Table/query
Row Source ==> kosongkan
Coloum Count ==> 1
Coloum Head ==> No

3. Misal, event yang kita manfaatkan adalah saat, pertama kali loading.

Private Sub Form_Load()
Dim tb as Variant
Dim db As Database
Dim rsp As ADODB.Recordset 'deklarasi rsp sebagai ADODB recordset

KONEKSI 'melakukan koneksi
If conn.State <> 0 Then 'bila sudah konek
contoh.RowSource = "" 'menghilangkan recordsource dulu biar tidak error
contoh.Visible = False 'tidak ditampilkan dulu
tb = "temp_" & KOM 'nama tabel temporer yang akan kita buat
hp_tb (tb) 'hapus tabel temporer dulu bila sudah ada
'buat tabel temporer asumsi nama field=field1
'size 255
DoCmd.RunSQL "CREATE TABLE " _
& tb & " (field1 Text(255));"
'melihat data di tabel mysql
Set rsp = conn.Execute("SELECT left([Week_Subc],5)" _
& " From TblCultureProduction UNION" _
& " SELECT left([Week_Subc],5) From" _
& " TblCultureIncoming")
If Not rsp.EOF Then
DoCmd.Hourglass True
Set db = CurrentDb 'deklarasi db adalah currentdb
'mengisi record dengan --All--
db.Execute ("Insert into " _
& tb & " Values ('--All---')")
Do While Not rsp.EOF 'jika ada data, lakukan berulang sampai akhir
If rsp.Fields(0) <> "" Then 'jika record berisi
'isi tabel temporer dengan data Mysql
db.Execute ("Insert into " _
& tb & " Values ('" _
& EscapeQuotes(rsp.Fields(0)) _
& "')")
End If
rsp.MoveNext
Loop
db.Close
Set db = Nothing
DoCmd.Hourglass False
End If
rsp.Close
Set rsp = Nothing
contoh.RowSource = tb 'letakkan recordsource combo contoh
contoh.DefaultValue = """--All--""" 'menjadikan --All-- sebagai devault value
contoh.Visible = Trye 'Tampilkan
contoh.Requery 'refresh
Else
MsgBox "gagal koneksi"
End If
conn.Close 'menutup koneksi
Set conn = Nothing 'menghilangkan koneksi dari memori

End Sub

Semoga bisa membantu dan memberi semangat.

Hariyanto (Surabaya)