البحث في الموقع

السلام عليكم ورحمة الله اساتذتنا واخواننا في هذا المنتدى الجميل ارجو افادتي حول تعديل الكود الخاص بالسكنر المطلوب: تصغير حجم الصورة الماخوذة بالسكنر حيث ان كل صورة يبلغ حجمها 5 ميجا تنبيهي الى الاخطاء الموجودة في الكود لغرض التعلم هذا ولكم الاجر والثواب تحياتي للجميع Option Compare Database Option Explicit Dim destinationFolder As String Dim myScanPath As String Dim myScanPathWithID As String Dim myImageFullName As String Private Sub btnClose_Click() DoCmd.Close End Sub Private Sub btnDelete_Click() 'Make Sure PicPath not Null If IsNull(Path) Then MsgBox "لا بوجد مسار للصورة حتى تتم عملية الحذف", vbCritical + vbOKOnly, "نقص معلومات" Exit Sub End If On Error Resume Next If MsgBox("سيتم حذف المرفق نهائيا ولا يمكن التراجع عن الحذف مرة اخري", _ vbQuestion + vbYesNo + vbMsgBoxRight + vbDefaultButton2, _ "تأكيد الحذف") = vbYes Then DoCmd.RunCommand acCmdDeleteRecord Else DoCmd.CancelEvent End If End Sub Private Sub btnHdd_Click() 'Make Sure EmpID not Null If IsNull(EmpID) Or IsNull(TypeOfDocument) Or IsNull(DocumentNumber) Or IsNull(DocumentNumber) Or IsNull(FaceOrBack) Then MsgBox "يرجى اكمال المعلومات في الحقول قبل استعمال نسح صورة من الهارد", vbCritical + vbOKOnly, "نقص معلومات" Exit Sub End If Dim Syso As Object Dim MyFile As String myScanPath = "D:\MyScanDB" myScanPathWithID = myScanPath & "\" & [EmpID] Dim fso As Object Set fso = CreateObject("scripting.filesystemobject") If Not fso.FolderExists(myScanPathWithID) Then fso.createfolder (myScanPathWithID) End If Dim Addfile As Object Set Addfile = Application.FileDialog(3) With Addfile .AllowMultiSelect = False .InitialFileName = "" .Filters.Clear .Filters.Add "All Files", "*.*" If .Show = True Then MyFile = Trim(.SelectedItems(1)) destinationFolder = myScanPathWithID & "\" & [TypeOfDocument] & " " & [DocumentNumber] & " " & Format([DocumentDate], "yyyy-mm-dd") & " " & [FaceOrBack] & " " & Format([DateOfTransfer], "yyyy-mm-dd hh-mm-nn-ss") & ".jpg" Me.Path = destinationFolder DBEngine.Idle Set Syso = CreateObject("Scripting.FileSystemObject") Syso.copyfile MyFile, destinationFolder Set Syso = Nothing Else Exit Sub End If End With End Sub Private Sub btnPrevew_Click() DoCmd.GoToControl "Path" If IsNull(Me![Path]) Then MsgBox "لايوجد مرفق" Else Application.FollowHyperlink [Path] End If Exit_btnHdd_Click: Exit Sub Err_btnHdd_Click: MsgBox Err.Description Resume Exit_btnHdd_Click End Sub Private Sub btnScaner_Click() 'Make Sure EmpID not Null If IsNull(EmpID) Or IsNull(TypeOfDocument) Or IsNull(DocumentNumber) Or IsNull(DocumentNumber) Or IsNull(FaceOrBack) Then MsgBox "يرجى اكمال المعلومات في الحقول قبل استعمال السكنر", vbCritical + vbOKOnly, "نقص معلومات" Exit Sub End If myScanPath = "D:\MyScanDB" myScanPathWithID = myScanPath & "\" & [EmpID] myImageFullName = "" 'Make Sure Folder Exsist if Not Create One destinationFolder = Dir(myScanPathWithID, vbDirectory) If destinationFolder = vbNullString Then VBA.FileSystem.MkDir (myScanPathWithID) End If Dim hg, OldFile, DBwithEXT Dim fdialog As Office.FileDialog Dim filepath As String Dim sdialog As New WIA.CommonDialog Dim imagefile As WIA.imagefile On Error GoTo errorhandle Set fdialog = Application.FileDialog(msoFileDialogSaveAs) OldFile = myScanPathWithID DBwithEXT = Dir(OldFile) hg = myScanPathWithID & "\" & [TypeOfDocument] & " " & [DocumentNumber] & " " & Format([DocumentDate], "yyyy-mm-dd") & " " & [FaceOrBack] & " " & Format([DateOfTransfer], "yyyy-mm-dd hh-mm-nn-ss") & Right(DBwithEXT, 3) With fdialog .Title = "Save as" .AllowMultiSelect = False .InitialFileName = [hg] .InitialFileName = hg + ".bmp" If .Show Then filepath = .SelectedItems(1) ' Else Exit Sub End If Set imagefile = sdialog.ShowAcquireImage() imagefile.SaveFile filepath Me.Path = filepath End With errorhandleexit: Exit Sub errorhandle: MsgBox Err.Description Resume errorhandleexit End Sub MyPic.rar

السلام عليكم ... اخواني الاعزاء انا مبتدئة في الاكسس وارجو من حضرتكم مساعدتي لاني بحاجة الى النظام بأسرع وقت ممكن مع فائق الاحترام والتقدير... اختكم عبير... توثيق.rar