VBA อ่านไฟล์จาก internet

Function GetHTML(URL As String) As String
    Dim HTML As String
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", URL, False
        .Send
        GetHTML = .ResponseText
    End With
End Function

String Split in vba

Sub SplitValue() 
    Dim avarSplit As Variant 
    Dim intIndex As Integer 
    avarSplit = Split(Range("A1").Value, ",") 
    For intIndex = LBound(avarSplit) To UBound(avarSplit) 
        MsgBox "Item " & intIndex & " is " & avarSplit(intIndex) & _ 
        " which is " & Len(avarSplit(intIndex)) & " characters long", vbInformation 
    Next 
End Sub 

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

Ms Access&Visual Basic Connector/ODBC Using ADO, DAO and RDO

ที่มา : http://dev.mysql.com/doc/refman/5.0/es/myodbc-examples-programming.html

Private Sub myodbc_ado_Click()

Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim fld As ADODB.Field
Dim sql As String

'connect to MySQL server using MySQL ODBC 3.51 Driver
Set conn = New ADODB.Connection
conn.ConnectionString = "DRIVER={MySQL ODBC 3.51 Driver};"_
& "SERVER=localhost;"_
& " DATABASE=test;"_
& "UID=venu;PWD=venu; OPTION=3"

conn.Open

'create table
conn.Execute "DROP TABLE IF EXISTS my_ado"
conn.Execute "CREATE TABLE my_ado(id int not null primary key, name varchar(20)," _
& "txt text, dt date, tm time, ts timestamp)"

'direct insert
conn.Execute "INSERT INTO my_ado(id,name,txt) values(1,100,'venu')"
conn.Execute "INSERT INTO my_ado(id,name,txt) values(2,200,'MySQL')"
conn.Execute "INSERT INTO my_ado(id,name,txt) values(3,300,'Delete')"

Set rs = New ADODB.Recordset
rs.CursorLocation = adUseServer

'fetch the initial table ..
rs.Open "SELECT * FROM my_ado", conn
Debug.Print rs.RecordCount
rs.MoveFirst
Debug.Print String(50, "-") & "Initial my_ado Result Set " & String(50, "-")
For Each fld In rs.Fields
Debug.Print fld.Name,
Next
Debug.Print

Do Until rs.EOF
For Each fld In rs.Fields
Debug.Print fld.Value,
Next
rs.MoveNext
Debug.Print
Loop
rs.Close

'rs insert
rs.Open "select * from my_ado", conn, adOpenDynamic, adLockOptimistic
rs.AddNew
rs!Name = "Monty"
rs!txt = "Insert row"
rs.Update
rs.Close

'rs update
rs.Open "SELECT * FROM my_ado"
rs!Name = "update"
rs!txt = "updated-row"
rs.Update
rs.Close

'rs update second time..
rs.Open "SELECT * FROM my_ado"
rs!Name = "update"
rs!txt = "updated-second-time"
rs.Update
rs.Close

'rs delete
rs.Open "SELECT * FROM my_ado"
rs.MoveNext
rs.MoveNext
rs.Delete
rs.Close

'fetch the updated table ..
rs.Open "SELECT * FROM my_ado", conn
Debug.Print rs.RecordCount
rs.MoveFirst
Debug.Print String(50, "-") & "Updated my_ado Result Set " & String(50, "-")
For Each fld In rs.Fields
Debug.Print fld.Name,
Next
Debug.Print

Do Until rs.EOF
For Each fld In rs.Fields
Debug.Print fld.Value,
Next
rs.MoveNext
Debug.Print
Loop
rs.Close
conn.Close
End Sub

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

NCD ปรับ .Sql ใน Folder SQL และรวม Total

NCD ปรับ .Sql ใน Folder SQL และรวม Total

เมื่อรวบแล้ว จากขนาดไฟล์ 42M เหลือ 29M  Zip แล้วเหลือ 975 KB

Function Del_PersonTable()
Dim rst As Recordset
DoCmd.SetWarnings False
Set rst = CurrentDb.OpenRecordset("SELECT pcucode FROM pcucode GROUP BY pcucode ")
Do While Not rst.EOF
pcucode = rst.Fields("pcucode")
strTablename = "person_" & pcucode
CurrentDb.Execute " DROP TABLE " & strTablename

rst.MoveNext
Loop
End Function

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