المصرقع الكبير
09-May-2006, 06:15 PM
السلام عليكم اخواني:
حبيت ان اقدم لكم الفيجول بيسك 6.0
وهذا الرابط :
http://www.irradiance.net/NewStuff/Soft/vs6sp5.exe
ولقد وجدت الرابط بعد بحث طويل
لذا اوصيكم بالتحميل ....
وهذة بعض اكواد اللغة :
يساعدك هذا الكود فى وضع بيانات معينة فى قائمة من قاعدة البيانات
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
'Run multi select statment
rs.Open "SELECT au_lname FROM authors; SELECT fname FROM employee", "dsn=pubs", adOpenForwardOnly, adLockReadOnly
Do While Not rs.EOF
Me.lstAu.AddItem rs.Fields(0)
rs.MoveNext
Loop
'Get Next rs
Set rs = rs.NextRecordset
Do While Not rs.EOF
Me.lstEmp.AddItem rs.Fields(0)
rs.MoveNext
Loop
Set rs = Nothing
هذا الكود يقوم بانشاء جدول داخل قاعدة بيانات أكسس
Public Function CreateTable(DatabaseName As String, _
ByVal TableName As String) As Boolean
'DataBaseName is the file/path name of the database
'TableName is the name of the table you want to create
'Returns true if successful, false otherwise
'Project must include reference to DAO
On Error GoTo errorhandler
Dim oDB As DAO.Database
Dim td As DAO.TableDef
Dim f As DAO.Field
Set oDB = Workspaces(0).OpenDatabase(Database Name)
On Error GoTo errorhandler
If TableExists(oDB, TableName) Then GoTo errorhandler
'Create table object
Set td = oDB.CreateTableDef(TableName)
'Must add a field
'This adds an auto-incremented ID field
Set f = td.CreateField("ID", dbLong)
f.Attributes = dbAutoIncrField
'Append field to table
td.Fields.Append f
'Append Table to Database
oDB.TableDefs.Append td
oDB.Close
CreateTable = True
Exit Function
errorhandler:
If Not oDB Is Nothing Then oDB.Close
Set td = Nothing
Set f = Nothing
End Function
Private Function TableExists(oDB As Database, _
TableName As String) As Boolean
Dim td As DAO.TableDef
On Error Resume Next
Set td = oDB.TableDefs(TableName)
TableExists = Err.Number = 0
End Function
كود لتغيير كلمة المرور الخاصة بأكسس أثناء تشغيل البرنامج
--------------------------------------------------------------------------------
Public Function ChangeDatabasePassword(DBPath As String, _
newPassword As String, oldPassWord As String) As Boolean
'Usage: Change DatabasePassword
'Parameters: sDBPath: Full Path to Access Database
'newPassword: the password
'oldPassword: the previous password
'returns true on success false otherwise
If Dir(DBPath) = "" Then Exit Function
Dim db As DAO.Database
On Error Resume Next
Set db = OpenDatabase(DBPath, True, False, ";pwd=" & oldPassWord)
If Err.Number <> 0 Then Exit Function
db.newPassword oldPassWord, newPassword
ChangeDatabasePassword = Err.Number = 0
db.Close
End Function
كود لضغط قاعدة البيانات أكسس أثناء تشغيل البرنامج
--------------------------------------------------------------------------------
'********************************** *************** *********
'Passing values compactDB module
'Sour_path = Source path of existing database.
'Dest_Path = Target path
'
'Note -
'Add Microsoft Jet and Replication Objects X.X library,
'where (X.X is greater than or equal to 2.1).
'********************************** *************** **********
'Jet OLEDB:Engine Type Jet x.x Format MDB Files
'********************* ************************
' 1 JET10
' 2 JET11
' 3 JET2X
' 4 JET3X
' 5 JET4X
'********************************** *************** *********
Option Explicit
Public Function compactDB(ByVal SOUR_path As String, _
ByVal DEST_path As String) As Boolean
On Error GoTo Err_compact
Private JRO As New JRO.JetEngine
' Source and Destination connection path
Private DB_sour As String, DB_dest As String
DoEvents
DB_sour = "Provider=Microsoft.Jet.OLEDB.4.0;Da ta Source=" _
& SOUR_path
DB_dest = "Provider=Microsoft.Jet.OLEDB.4.0;Da ta Source=" _
& DEST_path & " ;Jet OLEDB:Engine Type=5"
JRO.CompactDatabase DB_sour, DB_dest
compactDB = True
Exit Function
Err_compact:
compactDB = False
MsgBox Err.Description, vbExclamation
End Function
'********************************** ***************
' Usage Module level or form level.
'********************************** ***************
' Dim source_path,Target_path as string
' source_path=App.Path & "\Nwind.MDB"
' Target_path=App.Path & "\CompactNwind.MDB"
' If not compactDB(source_path,Target_path) Then
' MsgBox "An error occurred while attempt to rename database " _
' & vbCrLf & vbCrLf & DBCP_Name, vbExclamation
' End If
اختبار ما اذا كان ملفات الأكسس أو الاكسل محمبة بكلمة مرور أم لا
--------------------------------------------------------------------------------
Public Function Password_Check(Path As String) As String
Dim db As DAO.Database
if dir(Path) = "" then
'Return 0 if file does not exist
Password_Check = "0"
Exit Function
end if
If Right(Path, 3) = "mdb" Then
On Error GoTo errorline
Set db = OpenDatabase(Path)
Password_Check = "False"
db.Close
Exit Function
ElseIf Right(Path, 3) = "xls" Then
On Error GoTo errorline
Set db = OpenDatabase(Path, True, False, "Excel 5.0")
Password_Check = "False"
db.Close
Exit Function
Else
'Assume it's not a valid file
'if correct extension is not present
Password_Check = "0"
Exit Function
End If
errorline:
Password_Check = "True"
Exit Function
End Function
وهذا كتاب رائع لكي تتعلم اللغة :
http://www.h4palestine.com/learn/vblearn.zip
تحياتي لكم جميعا
اخوكم
المصرقع الكبير
منقول
حبيت ان اقدم لكم الفيجول بيسك 6.0
وهذا الرابط :
http://www.irradiance.net/NewStuff/Soft/vs6sp5.exe
ولقد وجدت الرابط بعد بحث طويل
لذا اوصيكم بالتحميل ....
وهذة بعض اكواد اللغة :
يساعدك هذا الكود فى وضع بيانات معينة فى قائمة من قاعدة البيانات
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
'Run multi select statment
rs.Open "SELECT au_lname FROM authors; SELECT fname FROM employee", "dsn=pubs", adOpenForwardOnly, adLockReadOnly
Do While Not rs.EOF
Me.lstAu.AddItem rs.Fields(0)
rs.MoveNext
Loop
'Get Next rs
Set rs = rs.NextRecordset
Do While Not rs.EOF
Me.lstEmp.AddItem rs.Fields(0)
rs.MoveNext
Loop
Set rs = Nothing
هذا الكود يقوم بانشاء جدول داخل قاعدة بيانات أكسس
Public Function CreateTable(DatabaseName As String, _
ByVal TableName As String) As Boolean
'DataBaseName is the file/path name of the database
'TableName is the name of the table you want to create
'Returns true if successful, false otherwise
'Project must include reference to DAO
On Error GoTo errorhandler
Dim oDB As DAO.Database
Dim td As DAO.TableDef
Dim f As DAO.Field
Set oDB = Workspaces(0).OpenDatabase(Database Name)
On Error GoTo errorhandler
If TableExists(oDB, TableName) Then GoTo errorhandler
'Create table object
Set td = oDB.CreateTableDef(TableName)
'Must add a field
'This adds an auto-incremented ID field
Set f = td.CreateField("ID", dbLong)
f.Attributes = dbAutoIncrField
'Append field to table
td.Fields.Append f
'Append Table to Database
oDB.TableDefs.Append td
oDB.Close
CreateTable = True
Exit Function
errorhandler:
If Not oDB Is Nothing Then oDB.Close
Set td = Nothing
Set f = Nothing
End Function
Private Function TableExists(oDB As Database, _
TableName As String) As Boolean
Dim td As DAO.TableDef
On Error Resume Next
Set td = oDB.TableDefs(TableName)
TableExists = Err.Number = 0
End Function
كود لتغيير كلمة المرور الخاصة بأكسس أثناء تشغيل البرنامج
--------------------------------------------------------------------------------
Public Function ChangeDatabasePassword(DBPath As String, _
newPassword As String, oldPassWord As String) As Boolean
'Usage: Change DatabasePassword
'Parameters: sDBPath: Full Path to Access Database
'newPassword: the password
'oldPassword: the previous password
'returns true on success false otherwise
If Dir(DBPath) = "" Then Exit Function
Dim db As DAO.Database
On Error Resume Next
Set db = OpenDatabase(DBPath, True, False, ";pwd=" & oldPassWord)
If Err.Number <> 0 Then Exit Function
db.newPassword oldPassWord, newPassword
ChangeDatabasePassword = Err.Number = 0
db.Close
End Function
كود لضغط قاعدة البيانات أكسس أثناء تشغيل البرنامج
--------------------------------------------------------------------------------
'********************************** *************** *********
'Passing values compactDB module
'Sour_path = Source path of existing database.
'Dest_Path = Target path
'
'Note -
'Add Microsoft Jet and Replication Objects X.X library,
'where (X.X is greater than or equal to 2.1).
'********************************** *************** **********
'Jet OLEDB:Engine Type Jet x.x Format MDB Files
'********************* ************************
' 1 JET10
' 2 JET11
' 3 JET2X
' 4 JET3X
' 5 JET4X
'********************************** *************** *********
Option Explicit
Public Function compactDB(ByVal SOUR_path As String, _
ByVal DEST_path As String) As Boolean
On Error GoTo Err_compact
Private JRO As New JRO.JetEngine
' Source and Destination connection path
Private DB_sour As String, DB_dest As String
DoEvents
DB_sour = "Provider=Microsoft.Jet.OLEDB.4.0;Da ta Source=" _
& SOUR_path
DB_dest = "Provider=Microsoft.Jet.OLEDB.4.0;Da ta Source=" _
& DEST_path & " ;Jet OLEDB:Engine Type=5"
JRO.CompactDatabase DB_sour, DB_dest
compactDB = True
Exit Function
Err_compact:
compactDB = False
MsgBox Err.Description, vbExclamation
End Function
'********************************** ***************
' Usage Module level or form level.
'********************************** ***************
' Dim source_path,Target_path as string
' source_path=App.Path & "\Nwind.MDB"
' Target_path=App.Path & "\CompactNwind.MDB"
' If not compactDB(source_path,Target_path) Then
' MsgBox "An error occurred while attempt to rename database " _
' & vbCrLf & vbCrLf & DBCP_Name, vbExclamation
' End If
اختبار ما اذا كان ملفات الأكسس أو الاكسل محمبة بكلمة مرور أم لا
--------------------------------------------------------------------------------
Public Function Password_Check(Path As String) As String
Dim db As DAO.Database
if dir(Path) = "" then
'Return 0 if file does not exist
Password_Check = "0"
Exit Function
end if
If Right(Path, 3) = "mdb" Then
On Error GoTo errorline
Set db = OpenDatabase(Path)
Password_Check = "False"
db.Close
Exit Function
ElseIf Right(Path, 3) = "xls" Then
On Error GoTo errorline
Set db = OpenDatabase(Path, True, False, "Excel 5.0")
Password_Check = "False"
db.Close
Exit Function
Else
'Assume it's not a valid file
'if correct extension is not present
Password_Check = "0"
Exit Function
End If
errorline:
Password_Check = "True"
Exit Function
End Function
وهذا كتاب رائع لكي تتعلم اللغة :
http://www.h4palestine.com/learn/vblearn.zip
تحياتي لكم جميعا
اخوكم
المصرقع الكبير
منقول