02 Januari 2009

Program konversi database foxpro ke database acces

Mungkin ada diantara vbthok mania yang sekarang masih menggunakan program foxpro dan ingin berpindah ke program VB tapi bingung dengan database yang ada di foxpro? ato ada yang ingin membuat program konversi tapi masih bingung buatnya.Tenaang...penulis akan mencoba mengupasnya dalam artikel perdana menyambut tahun baru 2009...hehehe...out of topic
sebelumnya aktifkan dulu komponen pereference:
microsoft DAO 3.51 object librabry
microsoft ActiveX Data Object 2.5 librabry
microsoft outlook 10.0 object library

berikut tampilan programnya
nah ini script kodenya
'form 1
Const devName = "www.vbthok.co.cc"
Const myMail = "tome.mine@gmail.com"

'-----------Variables for reading & retrieving foxpro database
Dim myCon As Database
Dim myRec As Recordset
'--------------------------------------------------------------

'-----------Variables for reading & retrieving Access database
Dim newCon As New ADODB.Connection
Dim newRec As New ADODB.Recordset
'--------------------------------------------------------------

Dim xDatanum As Integer
Dim foxFile, mdbFile, xSQL As String

Private Sub Command1_Click()
'-----------Start Converting
xSQL = ""
On Error Resume Next

If File1.FileName = "" Or UCase(Right$(File1.FileName, 3)) <> "DBC" Then
MsgBox "Invalid Foxpro Database Selected" & vbCrLf & "Please Select a valid Foxpro Database (*.dbc)", vbCritical, devName
Exit Sub
Else
'---Stores the file name with the whole path
stroke1 = IIf(Len(Dir1.Path) = 3, "", "\")
foxFile = Trim(UCase(Left$(Drive1.Drive, 1)) & ":\" & Mid(Dir1.Path, 4, Len(Dir1.Path)) & stroke1 & File1.FileName)
MsgBox foxFile

End If

If Text1.Text = "" Then
MsgBox "Enter a Valid Name", vbCritical, devName
Exit Sub
End If

If Len(Text1.Text) > 8 Then
MsgBox "File Name cannot be more then 8 characters", vbInformation, devName
Exit Sub
End If

newFile = Text1.Text

'------Cheking if the File name contains any Junk characters----
For i = 1 To Len(newFile)

eachChar = Mid$(newFile, 1, i)
eachChar = Right(eachChar, 1)

If Asc(eachChar) <> 122 Then
MsgBox "No Characters other then alphabets are allowed", vbCritical, devName
Exit Sub
End If

If Asc(eachChar) > 90 And Asc(eachChar) < 97 Then
MsgBox "No Characters other then alphabets are allowed", vbCritical, devName
Exit Sub
End If

Next

If Option1.Value = False And Option2.Value = False Then
MsgBox "Select any one option for type of convertion", vbCritical, devName
Exit Sub
End If

stroke2 = IIf(Len(Dir2.Path) = 3, "", "\")
mdbFile = UCase(Left$(Drive2.Drive, 1)) & ":\" & Mid(Dir2.Path, 4, Len(Dir2.Path)) & stroke2 & Text1.Text
confirm = MsgBox("Confirm Convertion " & foxFile & " to " & mdbFile & ".mdb", vbYesNo, devName)

If confirm = 7 Then Exit Sub

Form1.MousePointer = 11

'--- "myCon" Provides link 2 Foxpro Database
Set myCon = OpenDatabase(foxFile, False, False, "Foxpro DBC")

'--Create MDB Database
Set newCon = DBEngine.Workspaces(0).CreateDatabase(mdbFile, dbLangGeneral, dbVersion30)

'--Opening the Database
newCon.Open "DRIVER={Microsoft Access Driver (*.mdb)};dbq=" & mdbFile

'-----------------------------------------------------------------

'--- "TableDefs.counts" the number of tables present in the Database

For j = 1 To myCon.TableDefs.Count
Debug.Print myCon.TableDefs(j - 1).Name
'Set myRec = myCon.Execute("Select * from " & myCon.TableDefs(j - 1).Name)
Set myRec = myCon.OpenRecordset(myCon.TableDefs(j - 1).Name)

'---------------Generating SQL statement for Creating Tables-----
Comma = " , "
SQL = ""
SQL = "Create Table " & myCon.TableDefs(j - 1).Name & "("

For q = 1 To myRec.Fields.Count
Debug.Print myRec.Fields(q - 1).Name

xDatanum = myRec.Fields(q - 1).Type

SQL = SQL & myRec(q - 1).Name & " " & Datatype(xDatanum)

If q < myRec.Fields.Count Then
SQL = SQL & Comma
Else
SQL = SQL & ""
End If

Next

SQL = SQL & ")"
'MsgBox SQL, vbCritical, devName
Set newRec = newCon.Execute(SQL)


'---------------End of SQL statement for Creating Tables-----------

'------------------------------------------------------------------

'-------------Generating SQL statement for Inserting Values-------------------------------

If Option2.Value = True Then
Do Until myRec.EOF
xSQL = ""
xSQL = "Insert Into " & myCon.TableDefs(j - 1).Name & " Values ("

For e = 1 To myRec.Fields.Count
xSQL = xSQL & "'" & RTrim(myRec.Fields(e - 1).Value) & "'"

If e < myRec.Fields.Count Then
xSQL = xSQL & Comma
Else
xSQL = xSQL & ""
End If
Next e
xSQL = xSQL & ")"
'MsgBox xSQL

Set newRec = newCon.Execute(xSQL)
myRec.MoveNext

Loop
'-------------End Of SQL statement for Inserting Values-------------------------------
End If
Next

'--------Closing the Database & Records--------------------------
myRec.Close
myCon.Close
'----------------------------------------------------------------

Form2.MousePointer = 11
Form2.Show 1

Me.MousePointer = 0

MsgBox "Database Converted Successfully", vbInformation, devName

End Sub

Private Sub Command2_Click()
'-------EXIT-----
End
End Sub

Private Sub Command3_Click()
Call CreateMsg
End Sub



Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub

Public Function Datatype(ByVal dataNum As Integer) As String

numData = dataNum

Select Case numData
Case 7:
founData = "int"

Case 10:
founData = "Char(10)"

Case Else
founData = "VarChar"
End Select

Datatype = founData

End Function

Private Sub Drive2_Change()
Dir2.Path = Drive2.Drive
End Sub

Public Sub CreateMsg()

Dim objOutlook As New Outlook.Application
Dim objOutlookmsg As Outlook.MailItem

Set objOutlookmsg = objOutlook.CreateItem(olMailItem)
Form1.MousePointer = 11
With objOutlookmsg
.To = myMail
.Subject = "Mas tomi' Dbf-2-Mdb Utility"
.Display 1
End With
Form1.MousePointer = 0
End Sub


'form 2
Private Sub Form_Load()
Timer1.Enabled = True
End Sub

Private Sub Timer1_Timer()

If PBar.Value < 35 Then
Label5.Caption = "Wait....." & vbCrLf & "Reading Foxpro Database"
PBar.Value = PBar.Value + 1
End If

If PBar.Value = 35 Then
Label5.Caption = "Wait....." & vbCrLf & "Creating Access Database"
PBar.Value = PBar.Value + 5
End If

If PBar.Value >= 40 And PBar < 60 Then
PBar.Value = PBar.Value + 2
End If

If PBar.Value >= 60 And PBar.Value < 100 Then
If Form1.Option1.Value = True Then
Label5.Caption = "Wait....." & vbCrLf & "Converting And Transfering Tables"
Else
Label5.Caption = "Wait....." & vbCrLf & "Transfering Tables And Records"
End If
PBar.Value = PBar.Value + 0.5

End If

If PBar.Value = 100 Then Unload Me

End Sub

Segitu ajah script kodenya, mudah kan?? kalo yang pengen langsung jadi silakan download disini

Tidak ada komentar: