ابو ياسين المشولي

انا عامل كود للشبكةوكود بدون شبكه وهذا هة بدون شبكه كان ودي ارفع ملف بس للاس CurrentProject.Path & "\DATA\StPicd" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg" ف النت عندنا مرة ضعيف

ماخيبت ظنك استاذي ابو خليل ابوخليل وصلت الى هذا فكانت النتيجه ممتازة وكانت المطلوب بانسبة لي ' On Error Resume Next Dim fdialog As Office.FileDialog Dim filepath As String Dim bb As String Dim sdialog As New WIA.CommonDialog Dim imagefile As WIA.imagefile On Error GoTo errorhandle bb = (Mid(CurrentDb("data1").Connect, InStrRev(CurrentDb("data1").Connect, "\") + 1, Len(CurrentDb("data1").Connect) - InStrRev(CurrentDb("data1").Connect, "\"))) Dim fso As Object Dim fldrname, fldrpath, FoldrPath As String FoldrPath = "Pictures" Set fso = CreateObject("scripting.filesystemobject") fldrpath = CurrentProject.Path & "\" & FoldrPath If Not fso.FolderExists(fldrpath) Then fso.CreateFolder (fldrpath) End If '================================== Set fdialog = Application.FileDialog(msoFileDialogSaveAs) If bb = "DATATAILORVATa" Then 'filepath = CurrentProject.Path & "\DATA\StPica" + "\" & nofatora & ".jpg" filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPica" + "\" & nofatora & ".jpg" ElseIf bb = "DATATAILORVATb" Then filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicb" + "\" & nofatora & ".jpg" 'filepath = CurrentProject.Path & "\DATA\StPicb" + "\" & nofatora & ".jpg" ElseIf bb = "DATATAILORVATc" Then 'filepath = CurrentProject.Path & "\DATA\StPicc" + "\" & nofatora & ".jpg" filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicc" + "\" & nofatora & ".jpg" ElseIf bb = "DATATAILORVATd" Then 'filepath = CurrentProject.Path & "\DATA\StPicd" + "\" & nofatora & ".jpg" filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicd" + "\" & nofatora & ".jpg" End If Set imagefile = sdialog.ShowAcquireImage() imagefile.SaveFile filepath PicPath = filepath imagefile.Requery errorhandleexit: Exit Sub errorhandle: If Err.Number = "-2147024816" Then If MsgBox("توجد صورة تحمل نفس الرقم" & vbNewLine & "هل تريد حذف الصورة القديمة" & vbNewLine & "في حال الرفض لم تتم الاضافه", vbCritical + vbYesNo + vbMsgBoxRight, "تنبيه") = vbYes Then TempVars.add "name", InputBox(Space(30) & " ادخـل رقم عددتكرار الفاتورة ", Space(30) & DLookup(" [الاسم_التجاري] ", "بيانات_الشركه"), "1") 'Kill filepath If bb = "DATATAILORVATa" Then 'filepath = CurrentProject.Path & "\DATA\StPica" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg" filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPica" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg" ElseIf bb = "DATATAILORVATb" Then filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicb" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg" 'filepath = CurrentProject.Path & "\DATA\StPicb" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg" ElseIf bb = "DATATAILORVATc" Then 'filepath = CurrentProject.Path & "\DATA\StPicc" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg" filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicc" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg" ElseIf bb = "DATATAILORVATd" Then 'filepath = CurrentProject.Path & "\DATA\StPicd" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg" filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicd" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg" End If Set imagefile = sdialog.ShowAcquireImage() imagefile.SaveFile filepath PicPath = filepath ' imagefile.Requery ' Else End If ElseIf Err.Number = "-2145320939" Then MsgBox "الاسكانر غير متصل", vbCritical + vbMsgBoxRight, "تنبيه" Else PicPath = Err.Number ' MsgBox Err.Description MsgBox " تم حـفـظ صـورة الفاتورة ( " & nofatora & " ) بنجاح" & " ", 48, DLookup(" [الاسم_التجاري] ", "بيانات_الشركه") & Space(5) End If Resume errorhandleexit

السلام عليكم وصلت لحل الى هذا وارجو ان يفيد الجميع ' On Error Resume Next Dim fdialog As Office.FileDialog Dim filepath As String Dim bb As String Dim sdialog As New WIA.CommonDialog Dim imagefile As WIA.imagefile On Error GoTo errorhandle bb = (Mid(CurrentDb("data1").Connect, InStrRev(CurrentDb("data1").Connect, "\") + 1, Len(CurrentDb("data1").Connect) - InStrRev(CurrentDb("data1").Connect, "\"))) Dim fso As Object Dim fldrname, fldrpath, FoldrPath As String FoldrPath = "Pictures" Set fso = CreateObject("scripting.filesystemobject") fldrpath = CurrentProject.Path & "\" & FoldrPath If Not fso.FolderExists(fldrpath) Then fso.CreateFolder (fldrpath) End If '================================== Set fdialog = Application.FileDialog(msoFileDialogSaveAs) If bb = "DATATAILORVATa" Then 'filepath = CurrentProject.Path & "\DATA\StPica" + "\" & nofatora & ".jpg" filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPica" + "\" & nofatora & ".jpg" ElseIf bb = "DATATAILORVATb" Then filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicb" + "\" & nofatora & ".jpg" 'filepath = CurrentProject.Path & "\DATA\StPicb" + "\" & nofatora & ".jpg" ElseIf bb = "DATATAILORVATc" Then 'filepath = CurrentProject.Path & "\DATA\StPicc" + "\" & nofatora & ".jpg" filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicc" + "\" & nofatora & ".jpg" ElseIf bb = "DATATAILORVATd" Then 'filepath = CurrentProject.Path & "\DATA\StPicd" + "\" & nofatora & ".jpg" filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicd" + "\" & nofatora & ".jpg" End If Set imagefile = sdialog.ShowAcquireImage() imagefile.SaveFile filepath PicPath = filepath imagefile.Requery errorhandleexit: Exit Sub errorhandle: If Err.Number = "-2147024816" Then If MsgBox("توجد صورة تحمل نفس الرقم" & vbNewLine & "هل تريد حذف الصورة القديمة" & vbNewLine & "في حال الرفض سيتم اضافة رقم عشوائي الى اسم الصورة لتمييزها", vbCritical + vbYesNo + vbMsgBoxRight, "تنبيه") = vbYes Then 'Kill filepath If bb = "DATATAILORVATa" Then 'filepath = CurrentProject.Path & "\DATA\StPica" + "\" & nofatora & "(" & "1" & ")" & ".jpg" filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPica" + "\" & nofatora & "(" & "1" & ")" & ".jpg" ElseIf bb = "DATATAILORVATb" Then filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicb" + "\" & nofatora & "(" & "1" & ")" & ".jpg" 'filepath = CurrentProject.Path & "\DATA\StPicb" + "\" & nofatora & "(" & "1" & ")" & ".jpg" ElseIf bb = "DATATAILORVATc" Then 'filepath = CurrentProject.Path & "\DATA\StPicc" + "\" & nofatora & "(" & "1" & ")" & ".jpg" filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicc" + "\" & nofatora & "(" & "1" & ")" & ".jpg" ElseIf bb = "DATATAILORVATd" Then 'filepath = CurrentProject.Path & "\DATA\StPicd" + "\" & nofatora & "(" & "1" & ")" & ".jpg" filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicd" + "\" & nofatora & "(" & "1" & ")" & ".jpg" End If Set imagefile = sdialog.ShowAcquireImage() imagefile.SaveFile filepath PicPath = filepath ' imagefile.Requery ' Else End If ElseIf Err.Number = "-2145320939" Then MsgBox "الاسكانر غير متصل", vbCritical + vbMsgBoxRight, "تنبيه" Else PicPath = Err.Number ' MsgBox Err.Description MsgBox " تم حـفـظ صـورة الفاتورة ( " & nofatora & " ) بنجاح" & " ", 48, DLookup(" [الاسم_التجاري] ", "بيانات_الشركه") & Space(5) End If Resume errorhandleexit ولكن لم استطيع كيف اجعله اكثر من واحد مثلا من واحد الى خمسه او عشر اقصد هذا filepath = CurrentProject.Path & "\DATA\StPica" + "\" & nofatora & "(" & "1" & ")" & ".jpg"

حبيبي ابو خليل معلمنا الجليل يسعدني مرورك انا بخير دامك بخير الله يسعدك هو كان عندي شغال بشرط واحد اي عندما يكون بمجلد واحد ولكن باربعه اجهزة مرتبطه بالشبكه والمشكله الاكبر اني حاليا في اليمن والنت عندنا ماشاء الله مايعادل 10% في بلادكم الحبيبه وان شاء الله بجد له حل سلامك وتحياتي لكل اخواننا المشرفين والمقيم على هذا المنتدى

السلام عليكم ورحمه الله وبركاته عندي كود عجزت فيه يطبع اسكنر On Error Resume Next Dim ID_PuB As String Dim bb As String bb = (Mid(CurrentDb("data1").Connect, InStrRev(CurrentDb("data1").Connect, "\") + 1, Len(CurrentDb("data1").Connect) - InStrRev(CurrentDb("data1").Connect, "\"))) ID_PuB = Me.nofatora.Value Const wiaFormatJPEG = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}" 'On Error GoTo Handle_Err On Error Resume Next Dim Dialog1 As New WIA.CommonDialog, DPI As Integer, PP As Integer, L As Integer Dim Scanner As WIA.Device Dim img As WIA.ImageFile Dim intPages As Integer Dim strFileJPG As String Dim blnContScan As Boolean Dim ContScan As String 'msgbox to chk if more pages are to be scanned Dim strFilePDF As String Dim RptName As String Dim strProcName As String strProcName = "ScanDocs" blnContScan = True intPages = 0 DPI = 200 PP = 1 'No of pages Set Scanner = Dialog1.ShowSelectDevice(WIA.WiaDeviceType.ScannerDeviceType, False) With Scanner.items(1) .Properties("6146").Value = 1 'Colour intent (1 for color, 2 for grayscale, 4 for b & w) .Properties("6147").Value = DPI 'DPI horizontal .Properties("6148").Value = DPI 'DPI vertical .Properties("6149").Value = 0 'x point to start scan .Properties("6150").Value = 0 'y point to start scan .Properties("6151").Value = 8.27 * DPI 'Horizontal extent .Properties("6152").Value = 11.69 * DPI 'Vertical extent for letter End With ' If CurrentProject.Path & "\DATA\StPic" & "\" & Trim(STR(nofatora)) & ".jpg" = [sora] Then 'If MsgBox(" يوجد مرفقات من قبل في هذا السجل هل تريد اضافه المزيد" & vbCrLf & vbCrLf & _ '"", vbYesNo + vbMsgBoxRight + vbExclamation, " تنبية ") = vbNo Then 'Exit Sub ' 'End If 'End If 'Kill CurrentProject.Path & "\DATA\StPic" & "\" & Trim(STR(nofatora)) & ".jpg" If bb = "DATATAILORVATa" Then Set img = Dialog1.ShowTransfer(Scanner.items(1), wiaFormatJPEG, True) intPages = Me.nofatora strFileJPG = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPica" & "\" & Trim(STR(intPages)) & ".jpg" img.SaveFile (strFileJPG) ElseIf bb = "DATATAILORVATb" Then Set img = Dialog1.ShowTransfer(Scanner.items(1), wiaFormatJPEG, True) intPages = Me.nofatora strFileJPG = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicb" & "\" & Trim(STR(intPages)) & ".jpg" img.SaveFile (strFileJPG) ElseIf bb = "DATATAILORVATc" Then Set img = Dialog1.ShowTransfer(Scanner.items(1), wiaFormatJPEG, True) intPages = Me.nofatora strFileJPG = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicc" & "\" & Trim(STR(intPages)) & ".jpg" img.SaveFile (strFileJPG) ElseIf bb = "DATATAILORVATd" Then Set img = Dialog1.ShowTransfer(Scanner.items(1), wiaFormatJPEG, True) intPages = Me.nofatora strFileJPG = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicd" & "\" & Trim(STR(intPages)) & ".jpg" ' strFileJPG = CurrentProject.Path & "\DATA\StPic" & "\" & ID_PuB & Trim(Str(intPages)) & ".jpg" ' strFileJPG = CurrentProject.Path & "\DATA\StPic" + "\" & ID_PuB & ".jpg" img.SaveFile (strFileJPG) DoCmd.SetWarnings False ' DoCmd.RunSQL "UPDATE Data SET Data.sora = [CurrentProject].[Path] & ""\DATA\StPic""+""\"" & nofatora & "".jpg"" " & vbCrLf & _ "WHERE (((Data.nofatora)=[Forms]![zx]![nofatora]));" DoCmd.SetWarnings True DoCmd.RunCommand acCmdSaveRecord MsgBox " تم حـفـظ صـورة الفاتورة ( " & nofatora & " ) بنجاح" & " ", 48, DLookup(" [الاسم_التجاري] ", "بيانات_الشركه") & Space(5) Set Scanner = Nothing Set img = Nothing ' strFileJPG = "" 'Prompt user if there are additional pages to scan strFilePDF = "" End If

بارك الله فيك وجعله في ميزان حسناتك

فكرة ممتازة ليت ملف تطبيقي ليستفيد الجميع

جرب هكذا لازم يكون في راس النمودج Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long هذا كود عامله انا يفتح الصورة اللي في المجلد اللي بنفس رقم الفاتورة ShellExecute Me.hwnd, "open", CurrentProject.path & "\StPic" & "\" & Trim(str(nofatora)) & ".jpg", "", "", 1 StPic=المجلد CurrentProject.path=موقع البرنامج nofatora=رقم الموظف .jpg= الصيغه

اعمل شرط في الجدول تحت الرصيد اكبر من صفر <0

اخي هذا حسب مافهمته من تصميم المنوذج Select Case Nz(OP1, "") Case 1 DoCmd.OpenReport "RepBalanceAll", acViewPreview Case 2 DoCmd.OpenReport "RepBalanceAll", acPreview, , "[EDate]Between [Forms]![frmReportBalance]![Con1] And [Forms]![frmReportBalance]![Con2]" Case 3 If IsNull(cbFr3) Then MsgBox "يجب اختيار الفرع اولا", vbCritical, "انتبه" Me.cbFr3.SetFocus Me.cbFr3.Dropdown Exit Sub Else DoCmd.OpenReport "RepBalanceAll", acPreview, , "[EDate]Between [Forms]![frmReportBalance]![Con1] And [Forms]![frmReportBalance]![Con2]and [Fr3Name]=[Forms]![frmReportBalance]![txtNameFr3]" End If End Select Pro-Acc-S7.rar

هل تقصد هكذا 01.rar

Dim obj As AccessObject, dbs As Object Set dbs = Application.CurrentData For Each obj In dbs.AllTables If Left(obj.Name, 4) <> "MSys" Then DoCmd.SetWarnings False DoCmd.RunSQL ("Delete * From " & obj.Name) DoCmd.SetWarnings True End If Next obj MsgBox "تم حذف سجلات جميع الجداول" راجع هذا هنا

اتفضل On Error GoTo أمر21_Err If MsgBox("هل تريد الحذف", vbYesNo + 48, "رسالة تنبيه") = vbYes Then With CodeContextObject On Error Resume Next DoCmd.GoToControl Screen.PreviousControl.Name Err.Clear If (Not .Form.NewRecord) Then DoCmd.RunCommand acCmdDeleteRecord End If If (.Form.NewRecord And Not .Form.Dirty) Then Beep End If If (.Form.NewRecord And .Form.Dirty) Then DoCmd.RunCommand acCmdUndo End If If (.MacroError <> 0) Then Beep MsgBox .MacroError.Description, vbOKOnly, "" End If End With Else MsgBox "تم الرجوع", 48, "رسالة تنبيه" End If أمر21_Exit: Exit Sub أمر21_Err: MsgBox Error$ Resume أمر21_Exit 20.rar

عمل ممتاز يعطيك الف عافية