Skip navigation

How to addcontrol in form of another mdb
This function is very simple for insert a command button with Event Procedure
in form any mdb (microsoft access)
This function coding by VBA and can work in VB
Please remember this library must be import to project first
“Microsoft Access 10.0 Libraries” or heigher

Function AddCtl(dbPathAndName As String, frmName As String, OName As String, NName As String)
Dim acc As Access.Application ‘ Destination of microsoft access database (mdb)
Dim frm As Form ‘ object form variable
Dim ctlO As Control ‘ object old control in that form variable (static point to reference by a new control)
Dim ctlN As Control ‘ object new that you will make variable
Dim mdl As Module ‘ object module for place Event Procedure of new control
Dim mdlLine As Long ‘ variable for count of line in module that you start insert a new procedure

‘****************** connect to that database and open destination form in design view ************
Set acc = CreateObject(“access.Application”)
On Error GoTo ExitErr
acc.OpenCurrentDatabase (dbPathAndName)
acc.DoCmd.OpenForm frmName, acDesign

Set frm = acc.Forms(frmmane) ‘ set variables for object form
Set mdl = frm.Module ‘ set variables for object module
Set ctlO = frm.Controls(OName) ‘ set valibles for reference control

‘ create a new control in form, place it in front of old control (or somewhere by reference to old control)
‘ and set it in to new control variable

Set ctlN = acc.CreateControl(frm.Name, acCommandButton, _
acDetail, , , ctlO.Left – (ctlO.Width + 50), ctlO.Top, ctlO.Width, ctlO.Height)

‘ set original properties for new control
ctlN.Name = NName
ctlN.Caption = “Hello!”
ctlN.OnClick = “[Event Procedure]”

‘ create a code “Procedure fon OnClick Event” etc., by “CreateEventProc command
‘ in this step VBA will create start line in some line of module, But we can get a number of line
‘ by itself
mdlLine = mdl.CreateEventProc(“Click”, ctlN.Name)

‘ and the next line from above is a start line of you command
mdl.InsertLines mdlLine + 1, “msgbox ” & Chr(34) & “Hello” & Chr(34)
‘ in anotherway you can in sert a code pattern form a file by method of module
‘ ex. mdl.addfromfile

‘besure close any object
acc.DoCmd.Close acModule, mdl.name , acSaveYes
acc.DoCmd.Close acForm, frm.Name, acSaveYes

Exitt:
acc.CloseCurrentDatabase
Set acc = Nothing
Exit Function

ExitErr:
MsgBox Err.Description
Resume Exitt
End Function

*//one sample for use the function like this : \\*
*\\send values to every variable in function and run //*

Sub runn()

Dim dbPth, frmN, OldN, NewN As String

dbPth = CurrentProject.Path & “\mdbform.mdb”
frmN = “frmtest”
OldN = “cmdExit”
NewN = “cmdTest”

call AddCtl(CStr(dbPth), CStr(frmN), CStr(OldN), CStr(NewN))

End Sub
………………………Gentleman Yeadram ……………………

Advertisements

Sub main()
Dim conn
Dim sql
Set conn = CurrentProject.Connection

if tbExist(“teacher)=false then

sql = “CREATE TABLE teacher ” & _
“(teacherid varchar(5) NOT NULL, ” & _
“teacher varchar(50) NOT NULL, ” & _
“teacherLastname varchar(30), ” & _
“subjectid char(4) NOT NULL, ” & _
“CONSTRAINT teacher_pk PRIMARY KEY (teacherid), ” & _
“CONSTRAINT teacher_fk FOREIGN KEY (subjectid) ” & _
“REFERENCES subject(subjectid));”

conn.Execute sql

elseif fldExist(“teacher”,”teacherLastName”)=false then

sql=”ALTER TABLE teacher ADD teacherLastName varchar(30);”
conn.Execute sql

end if
set conn=nothing

End Sub
‘——————————————————————————–

Function fldExist(ByVal tbN As String, ByVal fldN As String) As Boolean
Dim Rss As New ADODB.Recordset
Rss.Open tbN, CurrentProject.Connection, 1
Dim i As Long
For i = 0 To Rss.Fields.Count – 1
If Rss(i).NAME = fldN Then
fldExist = True
Exit Function
End If
Next
fldExist = False
End Function
‘——————————————————————————–

Function tbExist(ByVal tbN As String) As Boolean
Dim Rss As New ADODB.Recordset
Rss.Open “Select name from MsysObjects”, CurrentProject.Connection, 1
Do While Not (Rss.EOF)
If Rss(0) = tbN Then
tbExist = True
Exit Function
End If
Rss.MoveNext
Loop
tbExist = False
End Function

ตอบคำถาม ไว้ที่ :http://access.crtrading.net/webboard/view.aspx?id=173
นามสมมติ : GTM

Block IP by ASP

‘ เขียนเป็นลูปให้มันดูเท่ๆ ห์ไปงั้นแหละครับ หุหุ จริงๆแล้วเขียนมันตรงจะประหยัดบรรทัดกว่าด้วยซ้ำ
‘ lgIP=(arIP(0)*256*256*256)+(arIP(1)*256*256)+(arIP(2)*256)+arip(3)

‘ พอได้ lgIP แล้วก็เอาไปตรวจสอบกับฐานข้อมูลครับ พอดีไปหามาได้
‘ ไฟล์เป็น csv เอาไปเข้าดาต้าเบสของคุณเลยก็ได้ครับ ช่องแรกกับช่องสองหมายถึง Range ของมันนะครับ
‘ หมายความว่า ไอพีใดถ้ามากกว่าหรือเท่ากับช่องแรก และ น้อยกว่าหรือเท่ากับช่องสอง คือไอพีที่มาจาก ช่อง4
‘ ไปโหลดเอาครับ http://ip-to-country.webhosting.info/downloads/ip-to-country.csv.zip?XID=16c7cdf39df882d283c52f9e5e5ee107
‘ หรือเข้าไปแวะดูเค้าหน่อย http://ip-to-country.webhosting.info/node/view/6

ตอบคำถามไว้ที่ : http://www.thaicreate.com/index.php?modules=forum/?langkey=2
กระทู้ที่ 16619 นามสมมติ : GTM

Manage DBF by VBA
For some DBF that no have index table (FPT, TBK, CDX , etc.)
I just do anything by Link it into MDB and manage..

And for DBF that come with index table I can not link it into MDB first,
But we can open it by MS EXCEL and save as to another name.
And now we can link it into MDB and can manage them.
In this case I have writen a function like this..

_______________________________________________________________________________________________________
Function Cust_Prod(tbPATH As String, tbNAME As String)
Dim Ex As Excel.Application
Set Ex = CreateObject(“Excel.Application”)
On Error Resume Next
‘Ex.Visible = True
Ex.Workbooks.Open tbPATH & tbNAME & “.DBF”
Ex.ActiveWorkbook.SaveCopyAs tbPATH & “A” & Right(tbNAME, Len(tbNAME) – 1) & “.DBF”
Ex.ActiveWorkbook.CLOSE
Ex.Application.Quit
Set Ex = Nothing
End Function

_______________________________________________________________________________________________________

However, That way not realy work for us because the another name I’d mean to another file not original DBF
So we can read it only

And then I have found the way, I just connect DBF (come with index tables) by OLEDB
First we must download and register one DLL file like VFPOLE.dll (You can find it for free in internet)
And Just copy this to your new module. I hope every one can call my function. ^_^

Global Conn As New ADODB.Connection
Global Rs As New ADODB.Recordset
Global i As Integer
Global j As Long
Global sql As String

‘_______________________________________________________________________________________________________
Function oConn(ByVal pth As String)
On Error GoTo errExit
If Conn.State 0 Then Conn.Close
Conn.Open (“Provider=VFPOLEDB.1;Data Source=” & pth & “;Mode=ReadWrite|” _
& “Share Deny Read|Share Deny Write;Extended Properties=””;User ID=””;Password=””;” _
& “Mask Password=False;Cache Authentication=False;Encrypt Password=False;” _
& “Collating Sequence=MACHINE;DSN=”””)
Exit Function
errExit:
MsgBox Err.Number & ” : ” & Err.Description
End Function

‘_______________________________________________________________________________________________________
Function cConn()
If Rs.State 0 Then Rs.Close
If Conn.State 0 Then Conn.Close
End Function

Sub main()
Dim rndRec
Dim rndFld
Dim CntRec
Dim CntFld
Dim arRec()
Dim arFld()
Dim x, y
rndRec = (Rnd \ 1) + 2
rndFld = (Rnd \ 1) + 2
ReDim arRec(rndRec)
ReDim arFld(rndFld)
 
Dim rs ‘ as new adodb.recordset
Dim Conn ‘ as new adodb.connection
Set Conn = CurrentProject.Connection
 
sql = “Select * From table1;”
rs.Open sql, Conn, 1, 1
rs.MoveLast
CntFld = rs.Fields.COUNT – 1
CntRec = rs.RecordCount – 1
 
For x = 1 To rndRec
arRec(x – 1) = CntRec * Rnd \ 1
        For y = 0 To x
        If arRec(x – 1) = arRec(y) Then arRec(x – 1) = CntRec * Rnd \ 1
        Next
Next
 
For x = 1 To rndFld
arFld(x – 1) = CntFld * Rnd \ 1
        For y = 0 To x
        If arFld(x – 1) = arFld(y) Then arFld(x – 1) = CntFld * Rnd \ 1
        Next
Next
 
Dim strAns
strAns = “”
For x = 0 To rndRec – 1
rs.MoveFirst
        Do While Not rs.EOF
        If rs.AbsolutePosition = arRec(x) Then
        strAns = strAns & “Record No : ” & rs.AbsolutePosition & vbCrLf
        For y = 0 To rndFld – 1
        strAns = strAns & ”     Field No : ” & arFld(y) & ”   Field Name : ” & rs(arFld(y)).NAME & _
        ”   Field Value : ” & rs(arFld(y)) & vbCrLf
        Next
        End If
        rs.MoveNext
        Loop
Next
rs.CLOSE
 
Debug.Print strAns
 
End Sub
 
 
……………………………..
ตอบคำถาม ไว้ที่ http://www.thaicreate.com/index.php?modules=forum/?langkey=2
กระทู้หมายเลข :16733   นามสมมติ : GTM