کسی استفاده نکرد ؟
Printable View
بازکردن و وارد کردن فایلها در اکسس
در خصوص تاپیک 62 و جناب دلشکسته:
چطور میتوان مجموع زمان را برای بازه ای از زمان در داخل یک تیبل انجام داد.فرضا ما یک فیلد تاریخ در تیبل داریم و می خواهیم جمع ساعات کاری برای یک دوره یک ماهه شخصی را بررسی کنیم به طوری که تاریخ را از داخل یک فرم از ما بخواهد.
ممنونم.
دوستان برای شکیلتر شدن برنامه شکل کروسر موس رو به این صورت تغییربدین:
ابتدا این ماجول را کپی کنید:
Option Compare Database
'*********************** Code Starts Here **********************************
Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'================================================= ====================
' Globals for cursor handling
Global Const GCL_HCURSOR = (-12)
Global hSwapCursor As Long
Global hAniCursor As Long
'================================================= ====================
Public Const IDC_ARROW = 32512&
Public Const IDC_IBEAM = 32513&
Public Const IDC_WAIT = 32514&
Public Const IDC_CROSS = 32515&
Public Const IDC_UPARROW = 32516&
Public Const IDC_ICON = 32641&
Public Const IDC_SIZENWSE = 32642&
Public Const IDC_SIZENESW = 32643&
Public Const IDC_SIZEWE = 32644&
Public Const IDC_SIZENS = 32645&
Public Const IDC_SIZEALL = 32646&
Public Const IDC_NO = 32648&
Public Const IDC_HAND = 32649&
Public Const IDC_APPSTARTING = 32650&
Declare Function LoadCursorBynum Lib "user32" Alias "LoadCursorA" _
(ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Declare Function LoadCursorFromFile Lib "user32" Alias _
"LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Declare Function SetCursor Lib "user32" _
(ByVal hCursor As Long) As Long
'
Public Function Arrow_Pointer()
Screen.MousePointer = 1
End Function
Function ChangeCursor(strPathToCursor As String)
On Error GoTo Error_On_ChangeCursor
If Dir(strPathToCursor) <> "" Then
Dim lngRet As Long
lngRet = LoadCursorFromFile(strPathToCursor)
lngRet = SetCursor(lngRet)
End If
Exit_ChangeCursor:
Exit Function
Error_On_ChangeCursor:
Resume Exit_ChangeCursor
End Function
Public Function Default_Pointer()
Screen.MousePointer = 0
End Function
Public Function IBeam_Pointer()
Screen.MousePointer = 3
End Function
Function MouseCursor(CursorType As Long)
Dim lngRet As Long
lngRet = LoadCursorBynum(0&, CursorType)
lngRet = SetCursor(lngRet)
End Function
Public Function Replace_Cursor(PathToFile As String)
hAniCursor = LoadCursorFromFile(PathToFile)
hSwapCursor = SetClassLong(Screen.ActiveForm.hWnd, GCL_HCURSOR, hAniCursor)
End Function
Public Function Restore_Cursor()
hSwapCursor = SetClassLong(Screen.ActiveForm.hWnd, GCL_HCURSOR, hSwapCursor)
End Function
بعد روی رویداد MouseMove مورد نظرتان هر کدام از کدهایی که میخواید صدا بزنید مثلا برای تغییر شکل بصورت دست این کد را بزنید:
Call MouseCursor(32649)
با سلام خدمت دوستان
نمونه حاضر براي جلوگيري از ورود مقادير تكراي در سابفرم آماده شده درصورت ورود داده تكراري پيامي صادر و داده حذف ميگردد.براي اين منظور از تابع DCOUNT بهره گيري شده است .اميدوارم قابل استفاده باشه.
Private Sub girande_BeforeUpdate(Cancel As Integer)
Dim SID As String
Dim stLinkCriteria As String
Dim rsc As DAO.Recordset
Set rsc = Me.RecordsetClone
SID = Me.girande.Value
stLinkCriteria = "[girande]=" & "'" & SID & "'"
If DCount("girande", "query3", _
stLinkCriteria) > 0 Then
'Undo duplicate entry
Me.Undo
'Message box warning of duplication
MsgBox "Warning data " _
& SID & " has already been entered." _
& vbCr & vbCr, vbInformation, "Duplicate Information"
End If
Set rsc = Nothing
End Sub
سلام
اين كد رو اول توي يك ماجول كپي و ذخيره كنيد ، بعد مثلاً در لود فرم اصلي برنامه يا يك كامند باتون اين عبارت رو بنويسيد : SetAllowBypassKeyFalse
البته اگر يك بار اين ماجول اجرا بشه ديگه براي هميشه شيفت بسته ميشه و احتياجي نيست كه هر بار برنامه لود ميشه اين عمل تكرار بشه بنابر اين مي تونيد يك فرم در فايل بذاريد به همراه كامند باتون كه فقط در صورت نياز بهش رجوع كنيد . ويك نكته مهم اينكه حتماً قبل از بستن شيفت يك كپي لز فايل رو در جايي ذخيره كنيد .
نمونه آموزشي براي مديريت فيلدهاي الزامي با پيام هاي فارسي
لطفا فايل ضميمه رو ببينيد:
درصورت عدم ورود فيلدهاي الزامي پيام خطا صادر ميگردد
Option Compare Database
Private Sub Form_Error(DataErr As Integer, Response As Integer)
'If an error occurs because of missing data in a required field
'display our own custom error message
Const conErrRequiredData = 3314
Const conErrNotSavedData = 2169
If DataErr = conErrRequiredData Then
MsgBox ("درج اطلاعات در اين فيلد الزامي است")
If IsNull(Me.NationalId) Then
Me.NationalId.SetFocus
Me.NationalId.BackColor = vbYellow
ElseIf IsNull(Me.tel) Then
Me.tel.SetFocus
Me.tel.BackColor = vbYellow
End If
Response = acDataErrContinue
ElseIf DataErr = conErrNotSavedData Then
MsgBox ("داده ذخيره نشد")
Response = acDataErrContinue
Else
'Display a standard error message
Response = acDataErrDisplay
End If
End Sub
Private Sub NationalId_AfterUpdate()
Me.NationalId.BackColor = vbWhite
End Sub
Private Sub tel_AfterUpdate()
Me.tel.BackColor = vbWhite
End Sub
در مرحله اول کدهای زیر را در یک ماژول کیی کنید
Option Compare Database
Public Function StopManualTableDelete(YesOrNo As String)
Dim fld As DAO.Field
Dim db As DAO.Database
Dim tbl As DAO.TableDef
Dim SQL_CreateConstraint As String, SQL_DropConstraint As String
Dim strConstraint As String ' this variable holds the name of the constraint
Dim i As Integer
Dim tblNames As String, DeleteInfo As String
Set db = CurrentDb()
i = 0
For Each tbl In db.TableDefs
' Bypass system tables with autonumbers
' Also any hidden table that starts with "~"
If Mid(tbl.Name, 1, 4) <> "MSys" Then
If Left(tbl.Name, 1) <> "~" Then
For Each fld In db.TableDefs(tbl.Name).Fields
If dbAutoIncrField = (fld.Attributes And dbAutoIncrField) Then 'Find autonumber
DoCmd.Hourglass True
strConstraint = "con_" & fld.Name & "_" & tbl.Name 'Build constraint name
If YesOrNo = "YES" Then
i = i + 1
'Drop any existing autonumber field constraints if there is one.
If FindCheckConstraint(strConstraint) = True Then
SQL_DropConstraint = "ALTER TABLE " & tbl.Name & _
" DROP CONSTRAINT " & strConstraint
CurrentProject.Connection.Execute SQL_DropConstraint
End If
DoEvents ' await a while just in case
'create the new constraint to disallow the table from being deleted.
SQL_CreateConstraint = " ALTER TABLE " & tbl.Name & " ADD " & _
" CONSTRAINT " & strConstraint & _
" CHECK (" & fld.Name & " IS NOT NULL))"
'Debug.Print SQL_CreateConstraint
CurrentProject.Connection.Execute SQL_CreateConstraint
DeleteInfo = "äãí ÊæÇäíÏ"
End If
If YesOrNo = "NO" Then
'Drop any existing autonumber field constraints.
If FindCheckConstraint(strConstraint) = True Then
i = i + 1
SQL_DropConstraint = "ALTER TABLE " & tbl.Name & _
" DROP CONSTRAINT " & strConstraint
CurrentProject.Connection.Execute SQL_DropConstraint
DeleteInfo = "ãí ÊæÇäíÏ"
End If
End If
tblNames = tblNames & tbl.Name & vbNewLine
Exit For
End If
Next fld
End If
End If
Next tbl
db.Close
Set db = Nothing
DoCmd.Hourglass False
If i > 0 Then
MsgBox i & " ÊäÙíãÇÊ ÑÇ ÈÕæÑÊí ÇäÌÇã ÏÇÏå ÇíÏ ˜å " & DeleteInfo & " ÌÏÇæá ÑÇÈÕæÑÊ ÏÓÊí ÍÐÝ ˜äíÏ æ ÊÚÏÇÏÔÇä" _
& vbNewLine & ": ãæÑÏãí ÈÇÔÏ. Çíä ÌÏÇæá ÔÇãá" & vbNewLine & vbNewLine & tblNames
Else
MsgBox "There are no tables with Autonumber fields present in this database." _
& vbNewLine & "Therefore this code did not have any effect on this database."
End If
End Function
''''''''''''''''''''''''''''''
Public Function FindCheckConstraint(MyConstraint As String) As Boolean
'this function checks to see if a check constraint already exist on the autonumber field.
Dim fld As ADODB.Field
Dim rst As ADODB.Recordset
Set rst = CurrentProject.Connection.OpenSchema(adSchemaCheck Constraints)
Do Until rst.EOF
For Each fld In rst.Fields
If fld.Name = "CONSTRAINT_NAME" Then
If fld.Value = MyConstraint Then
'Debug.Print fld.Value
FindCheckConstraint = True
Exit For
End If
End If
Next fld
rst.MoveNext
Loop
End Function
'StopManualTableDelete("Yes") ÈÇ ÇäÊÎÇÈ Çíä Òíäå Úãá ÍÐÝ ÇäÌÇã äãíÔæÏ
'StopManualTableDelete("NO") ÈÇ ÇäÊÎÇÈ Çíä Òíäå Úãá ÍÐÝ ÇäÌÇã ãíÔæÏ
در مرحله دوم در نمای ماژول کلید Ctl+G را همزمان فشرده تا قسمت Immediate نمایش داده شود سپس کد زیر را در آنجا کپی کرده و دکمه Enter برنید
StopManualTableDelete("Yes")
حالت yes باعث عدم حذف جداول و حالت No باعث حذف جداول میشود.
میتوانید فقط بجای Yes _ کلمه No بنویسید
هربار که جدول جدید ایجاد می کنید برای عدم حذف میبایست مرحله دوم را مجدداً تکرار کنید
موفق باشید
سلام
آقاي فلاح ضمن تشكر با توجه به اختلال در فونت كدها ، ماجول مربوطه رو در قالب يك فايل اكسس و از طريق ويرايشگر كلاسيك به پستتون اضافه كنيد .
مقايسه اي بين SQLserver 2000 و MSAccess 2000
دوستان سايت زير مقايسه اي بين اين دو برنامه انجام داده است كه مقايسه جالبي است . فكر مي كنم نگاه كردن به آن خالي از لطف نباشد .
----------------------------------------
http://www.macromediax.com/Learn/archive.asp?id=92
امنيت در اكسس
فايلهاي Access در حالت عادي از امنيت خوبي برخوردار نيستند . نرم افزار MDB Secure 2008 نام برنامه اي است كه اين كار را براي شما انجام مي دهد . اين برنامه تعدادي از قابليتهاي بانك اكسس را فعال مي كند كه باعث بالا بردن امنيت نهايي فايل MDB مي شود . اين كارها در اين برنامه با چند كليك ، راحت انجام مي شود در حاليكه براي فعال كردن آنها به صورت دستي در اكسس حدود 30 دقيقه براي هر ديتا بيس طول مي كشد .
نسخه اصلي اين برنامه رايگان نمي باشد و شما مي توانيد نسخه Trial آن را دانلود كنيد .
---------------------------------------
http://www.mindwarp-consultancy-soft...-download.html
ايجاد پشتيبان در مسير دلخواه با درج تاريخ شمسي در انتهاي نام فايل بدون overwrite روي پشتيبان هاي قبلي
لطفا نمونه را ببينيد:(با ذكر اين نكته كه براي توليد نام پشتيبان از توابع دستكاري شده جناب آزادي بهره گرفته شده است)
قبل از اجرا فايل comdlg32.ocx را در داخل پوشه سيستم 32 كپي و رجسيتر نماييد.
Option Compare Database
Dim CommondialogControl2 As Control
Dim backfile As New FileSystemObject
Dim source As String, desti As String
Dim x, y, z As Integer
Private Sub Command0_Click()
On Error GoTo err
source = Application.CurrentProject.FullName
x = Len(Application.CurrentProject.Name)
desti = Mid(Application.CurrentProject.Name, 1, x - 4) & Make_Date(Shamsi(Date)) & ".mdb"
With CommonDialog2
.DialogTitle = "Backup"
.Filter = "mdbfles (*.mdb)|*.mdb"
.FileName = desti
FileName = .FileName
check2:
If Dir(FileName) = "" Then
.FileName = FileName
.ShowSave
FileName = .FileName
backfile.CopyFile source, FileName, False
Else
GoTo check
check:
FileName = .FileName
y = Len(FileName)
z = z + 1
FileName = Mid(FileName, 1, y - 4) & "(" & z & ")" & ".mdb"
GoTo check2
End If
MsgBox "Databas has been backedup in" & " " & FileName, vbInformation
End With
Exit Sub
err:
Beep
End Sub
Private Sub Command1_Click()
On Error GoTo err
desti = Application.CurrentProject.FullName
If MsgBox("are you sure", vbOKCancel, "restore") = vbOK Then
With CommonDialog2
.DialogTitle = "Restore"
.Filter = "Access Files(*.mdb)|*.mdb"
.ShowOpen
source = .FileName
End With
backfile.CopyFile source, desti, True
MsgBox "Databas has been restored", vbInformation
Else
Cancel = True
End If
Exit Sub
err:
Beep
End Sub
با تشکر از آقای فلاحنقل قول:
جلوگیری از حذف جداول
آیا کدی برای جلوگیری از Import/Export شدن جدواول نیز جود د ارد؟
با تشکر فراوان از جناب فلاح برای کدهای کاربردی که نوشته اند.
من کد ایجاد جدول با استفاده از فرم را میخوام از دوستانی که میتوانند کمکم کنند خواهش می کنم این کد رو بفرستند.
این کد برای ایجاد جدول در دیتابیس جاری کاربرد داره .نقل قول:
من کد ایجاد جدول با استفاده از فرم را میخوام از دوستانی که میتوانند کمکم کنند خواهش می کنم این کد رو بفرستند.
دریک فرم کامند باتونی ایجاد و کدهای زیر رو در رخداد کلیک اون کپی کنید و بجای Command0 نام کامند باتون مورد نظرتون رو جایگزین کنید
Private Sub Command0_Click()نمونه مرتبط :
Dim MyDatabase As Database
Dim NewTable As TableDef
Dim MyArtist As DAO.Index
Dim MyIndex2 As DAO.Index
Dim MyIndex3 As DAO.Index
' open database
Set MyDatabase = CurrentDb 'OpenDatabase(App.Path + "\mp3Base.mdb")
'create the table
Set NewTable = MyDatabase.CreateTableDef("mp3New")
On Error Resume Next
'delete the table if it already exists
MyDatabase.TableDefs.Delete NewTable.Name
'add the fields in the table, those used below are just an example
With NewTable
.Fields.Append .CreateField("Title", dbText, 30)
.Fields.Append .CreateField("Artist", dbText, 30)
.Fields.Append .CreateField("Album", dbText, 30)
.Fields.Append .CreateField("Year", dbText, 4)
.Fields.Append .CreateField("Comment", dbText, 30)
.Fields.Append .CreateField("Genre", dbText, 1)
.Fields.Append .CreateField("Position", dbText, 10)
End With
'add indexes in the table
Set MyArtist = NewTable.CreateIndex("Artist")
MyArtist.Fields.Append MyArtist.CreateField("Artist")
NewTable.Indexes.Append MyArtist
Set MyIndex2 = NewTable.CreateIndex("Title")
MyIndex2.Fields.Append MyIndex2.CreateField("Title")
NewTable.Indexes.Append MyIndex2
Set MyIndex3 = NewTable.CreateIndex("Position")
MyIndex3.Fields.Append MyIndex3.CreateField("Position")
NewTable.Indexes.Append MyIndex3
NewTable.Indexes.Refresh
MyDatabase.TableDefs.Append NewTable
MsgBox "جدول با موفقیت ایجاد شد"
'close database
MyDatabase.Close
End Sub
سلامنقل قول:
سلام
من برنامه شما را اجرا نمودم و برروی اولین خط "MyDatabase As Database" ارور می گیرد
لطفا بفرمائید خطای کار من در کجاست
ببینید در قسمت References گزینه Microsoft DAO Objects Library 3.6 تیک خورده ؟
بله گزینه مورد نظر تیک خورده
سلام
این عبارت رو به این شکل تغییر بدید ببینید درست میشه :
Dim MyDatabase As Database
به این شکل
Dim MyDatabase As DAO.Database
سلام
کد موردنظر را تغییر دادم ارور پیش آمده از روی آن خط عبور کرده و حال برروی خط زیر ارور می گیرد
کد HTML:.Fields.Append .CreateField("Title", dbText, 30)
سلام
عجيبه ! من كه نه در 2007 و نه در 2003 به مشكلي برنخوردم ، شما از چه ورژني استفاده مي كنيد و ضمناً اگر مقدوره رفرنسهايي كه تيك خورده رو اعلام كنيد .
سلام
ضمن تشکر از پیگیری شما
من تصویر رفرنسهای خود را ضمیمه نمودم
سلام
رفرنسهاتون هم کاملاً درسته حالا چرا ارور دارین الله اعلم ، این فایل رو روی یک دستگاه دیگه هم تست کنید و نتیجه رو اعلام کنید .
سلام
بازهم ضمن تشکر از جنابعالی
فایل مورد نظر را روی یک رایانه دیگر اجرا کردم و اجرا شد و یک جدول بنام MP3New ایجاد شد
ولی هنوز متوجه ایراد بوجود آمده روی رایانه خود نشده ام
سلام
احتمال میدم که Collection های موجود در VBA شما دچار اشکال شده و درست عمل نمی کنن بنابراین بهتره یکبار Office رو Uninstall و مجدداً نصب کنید .
ضمن سلام به حضور dadsara
مطمئناً مشکل در بخش References وجود داره .
عملاً Access در صورت وجود رفرنسی که در کنار آن واژه Missing درج شده باشد , در هنگام اجرای کد با خطا مواجه میشه .
با توجه به استفاده از DAO در داخل کدهای شما , نقیصه الزاماً با برداشتن تیک کنار Reference معیوب رفع میشه
دلایل ایجاد این نقیصه میتونه :
عدم وجود اون Reference بر روی کامپیوتر شما
ناسازگاری نسخه موجود بر روی کامپیوتر شما و کامپیوتری که فایل بر روی آن تهیه شده است
و یا رجیستر نبودن درست Reference بوده باشد
ضمناً توصیه میشه دوستان مقداری هم در خصوص گزینه Priority تحقیق کنن
با تشکر از شما
با سلام
شاید برای شما هم پیش اومده باشه که بخواهید به محض باز شدن گزارش و بصورت اتوماتیک به صفحه آخر گزارش منتقل شوید. بدون اینکه لازم باشه منتظر باشید گزارش لود بشه بعد با استفاده از کلیدهای navigator گزارش به صفحه آخر برید
من با کد زیر اینکار رو انجام میدم
DoCmd.Maximize
SendKeys "{F5}"
SendKeys "500"
SendKeys "{Enter}"
کد فوق باید در رویداد OnActive گزارش قرار بگیره
روشی دیگر:
دوستمون آقای پیروزمهر هم روش دیگه ای رو پیشنهاد کردن :
DoCmd.Maximize
SendKeys "{End}"
این دستور کوتاهتر و خواناتره. البته توجه داشته باشید در صورتی که خاصیت AutoResize ریپورت No باشه به صفحه آخر نمیره
به هر حال با توجه به نحوه نمایش گزارشتون دستور مناسب رو انتخاب کنید
موفق باشید...
سلام
من دنبال گزارش یا کدی هستم که بتونم شماره های جا افتاده در یک فیلد رو بهم نشون بده
مثلا یه جدول دارم به نام doc و یه فیلدداره به اسم no.
رکورد های این فیلد هم به صورت زیره:
1,2,4,5,7,9,10
می خوام یه گزارش بسازم که اعداد 3و6و8 که از مجموعه 1 تا 10 جا افتاده رو بهم نشون بده
سلام
دوست عزیز قبلا یک تاپیک با موضوعی شبیه همین عنوان ایجاد شده بود و به جواب هم رسید
درصورتیکه تاپیک خواسته جنابعالی را اجابت نمی کند نسبت به ایجاد یک تاپیک مستقل اقدام نمائید تا جواب مناسب ارائه گردد
باسلام. یک کد مخفی کننده navigation pan می خوام. اگه دوستی داره، لطفا کمک کنه...
در ضمن ایا روشی برای exe کردن فایل های اکسس وجود داره؟
یک سؤال هم داشتم
در access 2007 کدی هست که کلیدهای باز و بسته و تغییر اندازه بالای ا کسس حذف شود
ممنون میشوم راهنمایی کنید
اخذ مشخصات سخت افزاري كامپيوتر
نمونه ارائه شده براي به دست آوردن مشخصات سيستم كاربرد داره اميدوارم به دردتون بخوره
براي اجراي صحيح بايد رفرنس Microsoft WMI Scripting v2.1 libraryتيك خورده باشه
Public Function GetPCInfo()
'You need to have Microsoft WMI Scripting v2.1 library Registered in your references
DoCmd.Hourglass True
Dim SWbemSet(Arr) As SWbemObjectSet
Dim SWbemObj As SWbemObject
Dim varObjectToId(Arr) As String
Dim varSerial(Arr) As String
Dim i, j As Integer
Dim fld As String
On Error Resume Next
varObjectToId(1) = "Win32_Processor,Name"
varObjectToId(2) = "Win32_Processor,Manufacturer"
varObjectToId(3) = "Win32_Processor,ProcessorId"
varObjectToId(4) = "Win32_BaseBoard,SerialNumber"
varObjectToId(5) = "Win32_BaseBoard,manufacturer"
varObjectToId(6) = "Win32_Baseboard,product"
varObjectToId(7) = "Win32_BIOS,Manufacturer"
varObjectToId(8) = "Win32_OperatingSystem,SerialNumber"
varObjectToId(9) = "Win32_OperatingSystem,Caption"
varObjectToId(10) = "Win32_DiskDrive,Model"
For i = 1 To Arr
Set SWbemSet(i) = GetObject("winmgmts:{impersonationLevel=impersonat e}").InstancesOf(Split(varObjectToId(i), ",")(0))
varSerial(i) = ""
For Each SWbemObj In SWbemSet(i)
varSerial(i) = SWbemObj.Properties_(Split(varObjectToId(i), ",")(1)) 'Property value
varSerial(i) = Trim(varSerial(i))
If Len(varSerial(i)) < 1 Then varSerial(i) = "Unknown value"
Next
fld = "Txt" & i
Forms("FrmSystemInformationReader")(fld) = varSerial(i)
Next
DoCmd.Hourglass False
End Function
.......................
موفق باشيد
سلام دوست عزیز من تازه کارم این موردی که گفتین رو نتونستم فعال کنم خطا می ده چه کنم
ضمناً فراموش نکنید اگر در References وی بی ای ، گزینه Microsoft DAO 3.6 Object Library چک نخورده حتماً فعالش کنید .
"Name conflicts with existing module, project, or object library"
ممنون میشم جوابمو بدین
وقتي مي خوام از Common Dialog تو فرم خودم استفاده كنم يه Error عجيب غريب مي گيرم.
تصوير زير رو ببينين :
http://www.freeuploadimages.org/imag...gorzzli41x.jpg
دوستان گلم، كمك لطفاً ........