VBA Create Table

Function Create_NCD_Table()
Dim rsp As Recordset
Dim table_name As String
Set dbs = CurrentDb
Set rsp = CurrentDb.OpenRecordset("SELECT  ncd_code  FROM ncd_disease  WHERE ncd_code<>'' GROUP BY ncd_code")
Do While Not rsp.EOF
            ncd_code = rsp.Fields("ncd_code")
            table_name = "ncd_" & ncd_code
If TableExists(table_name) Then
    CurrentDb.TableDefs.Delete (table_name)
End If

Set TBL = dbs.CreateTableDef(table_name)
Set fld = TBL.CreateField("pcucode", dbText, 15)
TBL.Fields.Append fld
Set fld = TBL.CreateField("pid", dbText, 15)
TBL.Fields.Append fld
Set fld = TBL.CreateField("cid", dbText, 15)
TBL.Fields.Append fld
Set fld = TBL.CreateField("chronic", dbText, 15)
TBL.Fields.Append fld
Set fld = TBL.CreateField("vhid", dbText, 8)
TBL.Fields.Append fld
Set fld = TBL.CreateField("sick_year", dbText, 4)
TBL.Fields.Append fld
Set fld = TBL.CreateField("death_year", dbText, 4)
TBL.Fields.Append fld
Set fld = TBL.CreateField("birth_year", dbText, 4)
TBL.Fields.Append fld
'Set fld = TBL.CreateField("Field3", dbInteger)
'TBL.Fields.Append fld
'Set fld = TBL.CreateField("Field4", dbCurrency)
'TBL.Fields.Append fld
dbs.TableDefs.Append TBL
dbs.TableDefs.Refresh
rsp.MoveNext
Loop
End Function

VBA Ms Access - Get the Path to the Database (.mdb) File

It is often useful to obtain the path to the database (mdb) file, especially if you follow our tip to Store Images Using Relative Paths.

A common error is to assume that the 'current' path is set to the path of the database file (and therefore that images can be accessed using relative notation, for example). This can't be relied upon - some VBA functions can change the current path (eg "Dir"), and indeed the database can be opened with a different path altogether set as 'current'.

Below are 3 code-snippets you can use to obtain the path to the database (mdb) file in different situations. In each case if the database file is "C:\mydb\mydb.mdb" the functions return "C:\mydb\". These functions all work whether the database is opened via a local drive, mapped drive or a UNC path.

1) Access 2000 and later - Database Not Split.

If you only need to support Access 2000 and later, and do not have a split (front-end/back-end) database, then this is the simplest and most efficient method. If used in a split database architecture this returns the path to the front-end database - usually not what is desired.

Public Function GetDBPath() As String
    GetDBPath = CurrentProject.Path & "\"
End Function

2) Access 97 and later- Database Not Split.

If you need to support Access 97, and do not have a split (front-end/back-end) database, then use this method. If used in a split database architecture this returns the path to the front-end database - usually not what is desired.

Note that other approaches are possible which avoid the loop (and are therefore potentially slightly more efficient), but these either require use of the "Dir" function (which can give rise to recursion problems) or need additional references.

Public Function GetDBPath() As String
    Dim strFullPath As String
    Dim I As Integer

    strFullPath = CurrentDb().Name

    For I = Len(strFullPath) To 1 Step - 1
        If Mid(strFullPath, I, 1) = "\" Then
            GetDBPath = Left(strFullPath, I)
            Exit For
        End If
    Next
End Function

3) Split Front-End/Back-End - Get Path to Back-End.

If your database is a split (Front-End/Back-End) design, these functions return the path to the Back-End. The first version uses 'InStrRev'. InStrRev can give errors similar to reference problems on some systems (and is not available on Access 97), so a second version is provided which does not use InStrRev.

Using 'InStrRev':

Public Function GetDBPath() As String
    Dim strFullPath As String
    strFullPath = Mid(DBEngine.Workspaces(0).Databases(0).TableDefs("tblLinked").Connect, 11)
    GetDBPath = Left(strFullPath, InStrRev(strFullPath, "\"))
End Function

Not using 'InStrRev':

Public Function GetDBPath() As String
    Dim strFullPath As String
    strFullPath = Mid(DBEngine.Workspaces(0).Databases(0).TableDefs("tblLinked").Connect, 11)

    For I = Len(strFullPath) To 1 Step - 1
        If Mid(strFullPath, I, 1) = "\" Then
            GetDBPath = Left(strFullPath, I)
            Exit For
        End If
    Next
End Function

การเขียนโปรแกรม Access 2003 เชื่อมต่อฐานข้อมูล MySQL

ขั้นตอนมีดังนี้
1-โหลด MySQL ODBC 3.51 Driver จาก Web mysql.com มาลงก่อน

2-เข้าไป ที่ เมนู start > run > odbcad32.exe

เลือก system dsn tab

สร้าง DSN ใหม่โดยคลิก Add เลือก MySQL ODBC ...Driver กด finish

ป้อนชื่อ DataSource Name เช่น mysql_mydsn1

ป้อนชื่อ server ถ้าเครื่องตัวเอง ก็ localhost ป้อน user / password ตามปกติถ้าไม่ปรับแต่งอะไร password จะว่างไว้

และ user = root , แล้วเลือก database

ลอง กดปุ่ม test ถ้าบอก ว่า success ให้ผ่านไปข้อ 3 โดยกดปุ่ม OK , ถ้าไม่ผ่านต้องหาทางแก้ไข

3-เปิด MsAccess แล้ว สร้าง Database เปล่าใหม่ สมมุติชื่อ db1.mdb

เลือกเมนู

แฟ้ม > รับข้อมูลภายนอก> นำเข้า > เชื่อมโยงตาราง > เลือกชนิดแฟ้มเป็น ODBC Database()

เลือก Tab Machine Data Source จาก Select Data Souce Dialog box

เลือก mysql_mydsn1 DSN ที่ได้ทำไว้ในขั้นที่2 กดปุ่ม ok แล้ว เลือกตาราง

อาจ กดเลือกทั้งหมดได้ แล้ว กดปุ่ม ตกลง

4-ข้อมูลจะถูกเชื่อมมาสู่ MsAccess

การแก้ไขที่นี่มีผลกระทบกับ ใน Database ใหญ่

จึงต้องใช้ความระมัดระวังอย่างมาก

แต่จะง่ายในการป้อนข้อมูล หรือ สร้าง App เล็กๆ ได้

5-การยกเลิกการเชื่อมต่อ ก็แค่ ปิด file mdb เท่านั้น
ที่มา : http://cmpls.net/?name=knowledge&file=readknowledge&id=13

VBA-Ms Access Delete Table

Function Del_Table()
Dim rst As Recordset
Dim table_name As String
DoCmd.SetWarnings False
Set rst = CurrentDb.OpenRecordset("SELECT * FROM disease")
Do While Not rst.EOF
codedz = rst.Fields("codedz")
table_name = "r506_" & codedz & "_village"

If TableExists(table_name) Then
    CurrentDb.TableDefs.Delete (table_name)
End If

rst.MoveNext
Loop

VBA-Ms Access Update_dolacode

Function update_dolacode()
Dim rsz As Recordset
Dim rst As Recordset
DoCmd.SetWarnings False
Set rsz = CurrentDb.OpenRecordset("SELECT * FROM amphoe WHERE dolacode<>amp_code")
Do While Not rsz.EOF

amp_code = rsz.Fields("amp_code")
dolacode = rsz.Fields("dolacode")

DoCmd.RunSQL "UPDATE EPE0 set ADDRCODE=Replace(ADDRCODE, '" & dolacode & "', '" & amp_code & "',1,4) WHERE left(ADDRCODE,4)='" & dolacode & "'"


rsz.MoveNext
Loop

End Function

VBA Ms Access - การอ่าน Text file หลายๆไฟล์ แล้วนำมารวมเป็นไฟล์เดียว

Sub Read_text_File()
Dim rst As Recordset
DoCmd.SetWarnings False
Set FS_Write = CreateObject("Scripting.FileSystemObject")
Set FS_Read = CreateObject("Scripting.FileSystemObject")
Set rst = CurrentDb.OpenRecordset("SELECT * FROM files")
Do While Not rst.EOF
    file_name = rst.Fields("file_name")
    DoCmd.RunSQL ("DELETE FROM " & file_name)
      Set a2 = FS_Write.CreateTextFile("C:\rawae_f18\" & file_name & ".TXT", True)
        For p_year = 2550 To 2553
       
            Set a1 = FS_Read.OpenTextFile("C:\rawae_f18\" & p_year & "\" & file_name & ".TXT")
           
            Do Until a1.AtEndOfStream
                        sText = a1.ReadLine
                        a2.writeline (sText)
           
           
            Loop
           
            a1.Close

        Next p_year
            a2.Close
rst.MoveNext
Loop
End Sub

VBA-Ms Access Check TableExists

Function TableExists(TableName As String) As Boolean
'=================================================  ============================
' hlfUtils.TableExists
'-----------------------------------------------------------------------------
' Copyright by Heather L. Floyd - Floyd Innovations - www.floydinnovations.com
' Created 08-01-2005
'-----------------------------------------------------------------------------
' Purpose:  Checks to see whether the named table exists in the database
'-----------------------------------------------------------------------------
' Parameters:
' ARGUEMENT             :   DESCRIPTION
'-----------------------------------------------------------------------------
' TableName (String)    :   Name of table to check for
'-----------------------------------------------------------------------------
' Returns:  True, if table found in current db, False if not found.
'=================================================  ============================

Dim strTableNameCheck
On Error GoTo ErrorCode

'try to assign tablename value
strTableNameCheck = CurrentDb.TableDefs(TableName)

'If no error and we get to this line, true
TableExists = True

ExitCode:
    On Error Resume Next
    Exit Function

ErrorCode:
    Select Case Err.Number
        Case 3265  'Item not found in this collection
            TableExists = False
            Resume ExitCode
        Case Else
            MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "hlfUtils.TableExists"
            'Debug.Print "Error " & Err.number & ": " & Err.Description & "hlfUtils.TableExists"
            Resume ExitCode
    End Select

End Function

VBA-Ms Access Create_Batfile

Function Create_Batfile()
Set fs = CreateObject("Scripting.FileSystemObject")
'Set a = fs.CreateTextFile("C:\Zr506\update.sql", True)
'a.writeline ("UPDATE  configuration SET last_date ='" & EngDate(Last_Date) & "';")
'a.Close
txtServer = "localhost"

Set a2 = fs.CreateTextFile("C:\Zr506\update.bat", True)
Set rsz = CurrentDb.OpenRecordset("SELECT * FROM disease ")
Do While Not rsz.EOF
codedz = rsz.Fields("codedz")
    a2.writeline ("" & Postgres_Path & "psql -d " & Postgres_DB & " -f C:\Zr506\sick_r506_" & codedz & ".sql  -U postgres  -h  " & txtServer & "")
    a2.writeline ("" & Postgres_Path & "psql -d " & Postgres_DB & " -f C:\Zr506\death_r506_" & codedz & ".sql  -U postgres  -h  " & txtServer & "")
   
rsz.MoveNext
Loop


a2.writeline ("" & Postgres_Path & "psql -d " & Postgres_DB & " -f C:\Zr506\update.sql -U postgres  -h  " & txtServer & "")
a2.Close
stAppName = "C:\Zr506\update.bat"  '¤Ø³µéͧà»ÅÕè¹ Drive áÅÐ Path ¤ÃѺ
Call Shell(stAppName, 3)
End Function

VBA-Ms Access Import_Epe0

Function Import_Epe0(db_file)
If TableExists("EPE0") Then
    CurrentDb.TableDefs.Delete ("EPE0")
End If

DoCmd.TransferDatabase acImport, "Microsoft Access", "" & db_file & "", acTable, "epe0", "epe0", False
End Function