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:
Posting Komentar