نجوم المشاركات

وعليكم السلام جرب الكود التالي Sub Test() Dim ws As Worksheet Dim sh As Worksheet Dim arr As Variant Dim str As String Dim x As Long Dim i As Long Dim j As Long Set ws = Sheets("BUY") Set sh = Sheets("STORE") arr = ws.Range("E2:FJ" & ws.Cells(Rows.Count, 5).End(xlUp).Row).Value Application.ScreenUpdating = False For x = 2 To sh.Cells(Rows.Count, 1).End(xlUp).Row str = sh.Cells(x, 1).Value For i = UBound(arr, 1) To LBound(arr, 1) Step -1 For j = UBound(arr, 2) - 5 To LBound(arr, 2) Step -6 If arr(i, j) <> "" And arr(i, j) = str Then sh.Cells(x, 6).Value = arr(i, j + 1) sh.Cells(x, 7).Value = arr(i, j + 2) sh.Cells(x, 8).Value = arr(i, j + 3) sh.Cells(x, 10).Value = arr(i, j + 4) sh.Cells(x, 9).Value = arr(i, j + 5) GoTo Skipper End If Next j Next i Skipper: Next x Application.ScreenUpdating = True End Sub

تفضل اخي ناصر لعله المطلوب بطريقة بسيطة إضافة شرط على كود جلب بيانات.rar

تفضل يا سيدي: Private Sub cmdScan_Click() Dim Ret As Long, PictureFile As String PictureFile = mypathofdb() & "\PIC\" & "pic" & Me.ImageID & ".jpg" 'Ret = TWAIN_AcquireToFilename(Me.hwnd, PictureFile) Ret = TransferWithoutUI(300, RGB, 0, 0, 8.3, 11.7, PictureFile) If Ret = 0 Then Me.ImagePath = PictureFile Me![ImageFrame].Picture = Me![ImagePath] Else MsgBox "فشلت عملية المسح الضوئي", vbCritical, "تحذير" End If End Sub Private Sub cmdSelect_Click() 'TWAIN_SelectImageSource (Me.hwnd) PopupSelectSourceDialog End Sub . جعفر za-EMP.zip

السلام عليكم ورحمة الله وبركاته انا احد الاشخاص الذين لا يحبذ ان يستعمل الكود في تخفيف أمان الاكسس ، فقد وضعته شركة مايكروسوفت في حزمة الاوفيس حتى تحمينا من ايدي المخربين ، وفي هذا الرابط شرحت كيفية عمل مجلد موثوق به للأكسس 2007 فما فوق: http://www.officena.net/ib/topic/66450-دمج-ملف-وتشغيله-قبل-أو-مع-بدء-اكسس/#comment-432363 المشكلة في كود تخفيف الامان ، انه لا يخفض مستوى أمان الاكسس لبرنامجك فقط ، وانما يخفض مستوى أمان جميع برامج الاكسس. ولكننا كمبرمجين لدينا مشكلتنا ، في انه اذا ارسلت برنامجك الى شخص ما ، فلا بد من التواصل معه و اعطاؤه الخطوات كما في الرابط ، وإلا فالبرنامج لن يعمل ، لان البرنامج يشتمل على الماكرو والوحدات النمطية. هنا اقدم لكم طريقة لجعل برنامجي فقط يعمل بمستوى أمان أقل ، فلا تظهر لي رسالة الأمان من الاكسس. العمل كله يدور حول كود ، ويجب حفظ الكود هذا في ملف بصيغة vbs ، والذي يجب ان نفتح برنامجنا عن طريقه. الكود يعمل على برامج الاكسس بصيغة mdb و accdb ، والمفروض ان يعمل على جميع اصدارات الاكسس 2003 فما فوق ، وعلى الاكسس 32بت و64بت (انا هنا اطلب من الشباب تجربته بإصدارات الاكسس التي يعملون عليها ، وإخبارنا بالنتيجة لوسمحتوا). اليكم طريقة العمل (رجاء انزال المرفق وفكه في المسار C:\jj ، وذلك حتى يمكنكم متابعة خطواتي): رجاء وضع البرنامج المرفق Seq.mdb حسب المسار التالي: C:\jj\Seq.mdb الآن اذهب الى المجلد C:\jj وافتح البرنامج Seq.mdb بالنقر المزدوج ، عند فتحه نرى رسالة أمان الاكسس ، وهذا متوقع ، وذلك بسبب انه في مجلد غير موثوق به (رجاء لا تضف هذا المجلد كمجلد أمان ، وانما اخرج من البرنامج). . الملف الآخر المرفق Seq.vbs ، يحتوي على هذا الكود: rem http://www.accessmvp.com/jconrad/accessjunkie/macrosecurity.html rem expression.OpenCurrentDatabase(filepath required, Exclusive optional, bstrPassword optional) dim o set o=createobject ("Access.Application") o.automationsecurity=1 ' set macro security LOW. o.opencurrentdatabase "C:\jj\Seq.mdb" o.usercontrol=true set o=nothing . تستطيع ان تجعله في اي مجلد (ممكن تجرب نسخه منه في اي مجلد شئت) ، وانقر مرتين على هذا الملف بُغية تشغيله ، سترى انه فتح البرنامج Seq.mdb ، وبدون رسالة أمان الاكسس ، وهو المطلوب ------------------------------------------------------------------------------------------------------------------------------------------- هذه الخطوة إضافية ، وهي لتحويل الملف السابق من صيغة vbs الى exe ، واختيار ايقونه للملف الجديد الآن ننتقل للخطوة التالية ، وهي ، اننا لا نريد ان ايقونة vbs ، وانما نريد ايقونه خاصة لبرنامجنا. هناك طريقتين: 1. ايقونة مختصر البرنامج Shortcut: وهي ان نعمل مختصر لملف Seq.vbs ، ولكن وللأسف مختصر ملف vbs يعطينا نفس ايقونة الملف نفسه ، وما عندنا طريقة لتغييرها!! لذلك ، سنعمل مختصر لملف الاكسس ، ونغير البيانات كالصورة التاليه ، بحيث يصبح مختصر ملف vbs يحتوي على ايقونة ملف الاكسس (طبعا يمكنك ان تغير الايقونة الى اي شئ شئت): . . . . وبهذه الطريقة غيّرنا ايقونة برنامج vbs الى ايقونه اخرى مناسبة 2. تحويل ملف vbs الى ملف تنفيذي exe ، وتختار له الايقونة التي تعجبك: رجاء انزال البرنامج المجاني Vbs to Exe من الرابط التالي: http://www.f2ko.de/en/v2e.php احد اسباب اختياري لهذا البرنامج ، اننا نستطيع التحكم به عن طريق Commandline ايضا ثم نتبع الخطوات التالية: ونستطيع ان نعمل لبرنامج vbs هذا كلمة سر كذلك ، . في الخطوة 6 تستطيع ان تكتب معلومات شركتك ، ونختار الايقونه التي نريدها للبرنامج (الخطوة 5) . . وتستطيع ان تجعله على سطح مكتب كمبيوترك الميزة في هذه الطريقة ، ان المستخدم لن يعرف مكان برنامج قاعدة البيانات Seq.mdb ، ولن يعرف الكود الذي كان في Seq.vbs ارجو ممن يضع ردا على الموضوع ، ان يذكر: 1. اذا اشتغل البرنامج على كمبيوتره ، 2. نسخة الاكسس التي يستخدمها. ملاحظة: الظاهر ان بعض متصفحات الانترنت حجبت انزال المرفق Seq.zip ، وذلك بسبب احتوائه على ملف vbs ، والذي يستخدمه الكثيرون لتخريب الكمبيوتر ، لذلك ، ارفق لكم Seq_2.zip والذي يحتوي على نفس ملفات Seq.zip ، ولكني غيرت صيغة الملف Seq.vbs الى Seq.txt . بعد انزال المرفق وفك ملفاته في الكمبيوتر ، رجاء تغيير مسمى الملف Seq.txt الى Seq.vbs جعفر Seq.zip Seq_2.zip

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

تم معالجة الامر 3454 salim.rar

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

شكرا جعفر

أخي الكريم ماهي الفائدة من هذا الاجراء ؟ الأكسس فيه مميزات عديدة تغنيك عن عمل الأكسل الذي تضطر فيه للنقل من صفحة الى أخرى الأكسس قاعدة بيانات متكاملة تسهل عليك العمل نقل بيانات جدول من جدول آخر أمر غير منطقي في قواعد البيانات اذا شرحت مامشكلتك بالضبط ربما نساعدك في ايجاد طريقة تغنيك عن هذا النسخ و الله الموفق

اخي حمادة وبعد اذن اخي واستاذي عبدالله بقشير الذي تعلمنا منه الكثير في ههذا المنتدى الكبير والعزيز وبعد اخي حماده ما عليك عمله خطوتان الأولى ان تذهب الصفحه KH وتكتب اسم الكود او علامة التمييز للقائمة الفرعية العامود C او G بعدها اذهب الى محرر الاكواد واضف في Module2 مثلا كود الأستاذ عبدالله بقشير KH_1 انظر الموديل هكذا Sub kh_1() MsgBox "تم الحفظ" End Sub ضع مثلا Sub kh_1() USERFORM.SHOW End Sub او أي اسم يوزر فورم موجوده في البرنامج بتاعك ارجو ان تكون الفكره واضحه في هذا الشرح

اخى جرب الكود التالى هو للاخ الفاضل ياسر العربى بارك الله فيه تقبل تحياتى حالات التقاعد1.rar

السلام عليكم تفضل جرب هذا الملف بعد التعديل موظفين.rar

وعليكم السلام واهلا وسهلا بك في المنتدى قواعد المشاركة فى الموقع اضغط هنـــــــــامن فضلك لقراءة القواعد كاملة و بصفة خاصة نؤكدعلى ما يلي 1- يمنع منعا باتا نشر أية مواد تخالف حقوق الملكية الفكرية و يرجى الابلاغ عن المشاركات المخالفة من خلال زر تقرير اسفل المشاركة 2-يجب استخدام خاصيةالبحث قبل طرح السؤال توفيرا للوقت و الجهد. 3-ضرورة كتابة عنوان واضح للموضوع يدل على محتواه ويعطي وصفاً مختصرا للسؤال. 4-ممنوع منعا باتاً كتابة عناوين سينمائية مثل عاجل ، نداء الي فلان ، الي الخبراء ، طلب مساعدة ، أريد حلا..... 5-يمكن استعجال الرد باستخدام تعبير -للرفع- و غير مسموح بالالحاح او اللوم فجميع الاعضاء يشاركون تطوعا طبقا لسعة وقتهم. ومخالفة ذلك تعرض الموضوع للحذف المنتدى مليئ بمثل هذه المواضيع ، ويمكنك البحث وستجد الكثير منها ، وآخرها . مخالف - يُقفل. جعفر

1. PopupSelectSourceDialog 2. TransferWithUI("d:\j.bmp") 3. TransferWithoutUI(300, rgb, 0, 0, 8.3, 11.7,"D:\jj2.bmp") لا تستعملهم كلهم مع بعض ، وانما: 1. اختار الاسكانر ، ثم اختار 2 او 3. اريد صورة منها ، وكذلك صورة من صفحة الكود والسطر ذو اللون الاصفر. في اعتقادي انه بعد ان اضفنا الدوال اعلاه الى برنامجك ، بعضها كان موجودة في الوحدة النمطية القديمة ، لذا يجب ان نوقفها !! جعفر حلللللوة ، وحنا قاعدين نضرب اخماس في اسداس لمعرفة المشكلة جعفر

السلام عليكم الموضوع التالي يستخدم نفس كود برنامجك تقريبا : . ولكن للأسف ما اشتغل على جهازي وندوز 10 !! وبحثت ، وعرفت ان الكود يعمل على XP و Vista ولا يعمل على 7 او 8 او 10 ، ولكن الكود التالي يعمل عندي ، وطرق مناداته: 1. لإختيار الجهاز ، 2. لإظهار نافذة جهاز الاسكانر ، 3. للنسخ من الاسكانر بدون نوافذ: 1. PopupSelectSourceDialog 2. TransferWithUI("d:\j.bmp") 3. TransferWithoutUI(300, rgb, 0, 0, 8.3, 11.7,"D:\jj2.bmp") Option Compare Database '******************************************************************************* ' ' Description: VB Module for accessing TWAIN compatible scanner (VB 5, 6) ' ' Author: Lumir Mik (lmik@seznam.cz) ' ' Version: 1.0 ' ' License: Free to any use. If you change some part of this code, please, ' mention it here. ' Receive it as my contribution to free programmer sources ' in which I found much help and inspiration. ' ' There are 3 public functions in this module: ' ' 1. PopupSelectSourceDialog ' shows TWAIN dialog for selecting default source for acquisition ' ' 2. TransferWithoutUI ' transfers one image from TWAIN data source without showing ' the data source user interface (silent transfer). The programmer ' can set following attributes of the image: ' - resolution (DPI) ' - colour depth - monochromatic, grey, fullcolour ' - image size and position on the scanner glass ' - left, top, right, bottom (in inches). ' The image is saved into the BMP file. ' ' 3. TransferWithUI ' transfers one image from TWAIN data source using the data ' source user interface to set image attributes. ' The image is saved into the BMP file. ' '******************************************************************************* Option Explicit '----------------------------- ' Declaration for TWAIN_32.DLL '----------------------------- Private Declare Function DSM_Entry Lib "Twain_32.dll" _ (ByRef pOrigin As Any, _ ByRef pDest As Any, _ ByVal DG As Long, _ ByVal DAT As Integer, _ ByVal MSG As Integer, _ ByRef pData As Any) As Integer Private Type TW_VERSION MajorNum As Integer ' TW_UINT16 MinorNum As Integer ' TW_UINT16 Language As Integer ' TW_UINT16 Country As Integer ' TW_UINT16 Info(1 To 34) As Byte ' TW_STR32 End Type Private Type TW_IDENTITY Id As Long ' TW_UINT32 Version As TW_VERSION ' TW_VERSION ProtocolMajor As Integer ' TW_UINT16 ProtocolMinor As Integer ' TW_UINT16 SupportedGroups1 As Integer ' TW_UINT32 SupportedGroups2 As Integer Manufacturer(1 To 34) As Byte ' TW_STR32 ProductFamily(1 To 34) As Byte ' TW_STR32 ProductName(1 To 34) As Byte ' TW_STR32 End Type Private Type TW_USERINTERFACE ShowUI As Integer ' TW_BOOL ModalUI As Integer ' TW_BOOL hParent As Long ' TW_HANDLE End Type Private Type TW_PENDINGXFERS Count As Integer ' TW_UINT16 Reserved1 As Integer ' TW_UINT32 Reserved2 As Integer End Type Private Type TW_ONEVALUE ItemType As Integer ' TW_UINT16 Item1 As Integer ' TW_UINT32 Item2 As Integer End Type Private Type TW_CAPABILITY Cap As Integer ' TW_UINT16 ConType As Integer ' TW_UINT16 hContainer As Long ' TW_HANDLE End Type Private Type TW_FIX32 Whole As Integer ' TW_INT16 Frac As Integer ' TW_UINT16 End Type Private Type TW_FRAME Left As TW_FIX32 ' TW_FIX32 Top As TW_FIX32 ' TW_FIX32 Right As TW_FIX32 ' TW_FIX32 Bottom As TW_FIX32 ' TW_FIX32 End Type Private Type TW_IMAGELAYOUT Frame As TW_FRAME ' TW_FRAME DocumentNumber As Long ' TW_UINT32 PageNumber As Long ' TW_UINT32 FrameNumber As Long ' TW_UINT32 End Type Private Type TW_EVENT pEvent As Long ' TW_MEMREF TWMessage As Integer ' TW_UINT16 End Type Private Const DG_CONTROL = 1 Private Const DG_IMAGE = 2 Private Const MSG_GET = 1 Private Const MSG_SET = 6 Private Const MSG_XFERREADY = 257 Private Const MSG_CLOSEDSREQ = 258 Private Const MSG_OPENDSM = 769 Private Const MSG_CLOSEDSM = 770 Private Const MSG_OPENDS = 1025 Private Const MSG_CLOSEDS = 1026 Private Const MSG_USERSELECT = 1027 Private Const MSG_DISABLEDS = 1281 Private Const MSG_ENABLEDS = 1282 Private Const MSG_PROCESSEVENT = 1537 Private Const MSG_ENDXFER = 1793 Private Const DAT_CAPABILITY = 1 Private Const DAT_EVENT = 2 Private Const DAT_IDENTITY = 3 Private Const DAT_PARENT = 4 Private Const DAT_PENDINGXFERS = 5 Private Const DAT_USERINTERFACE = 9 Private Const DAT_IMAGELAYOUT = 258 Private Const DAT_IMAGENATIVEXFER = 260 Private Const TWRC_SUCCESS = 0 Private Const TWRC_CHECKSTATUS = 2 Private Const TWRC_DSEVENT = 4 Private Const TWRC_NOTDSEVENT = 5 Private Const TWRC_XFERDONE = 6 Private Const TWLG_CZECH = 45 Private Const TWCY_CZECHOSLOVAKIA = 42 Private Const TWON_PROTOCOLMAJOR = 1 Private Const TWON_ONEVALUE = 5 Private Const TWON_PROTOCOLMINOR = 9 '------------------------- ' Declaration for WIN32API '------------------------- Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _ (ByVal pDest As Long, _ ByVal pSource As Long, _ ByVal Length As Long) Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" _ (ByVal pDest As Long, _ ByVal Length As Long) Private Declare Function GlobalFree Lib "kernel32.dll" _ (ByVal hMem As Long) As Long Private Declare Function GlobalLock Lib "kernel32.dll" _ (ByVal hMem As Long) As Long Private Declare Function GlobalUnlock Lib "kernel32.dll" _ (ByVal hMem As Long) As Long Private Declare Function GlobalAlloc Lib "kernel32.dll" _ (ByVal wFlags As Long, _ ByVal dwBytes As Long) As Long Private Declare Function GetMessage Lib "user32.dll" Alias "GetMessageA" _ (ByRef lpMsg As MSG, _ ByVal hwnd As Long, _ ByVal wMsgFilterMin As Long, _ ByVal wMsgFilterMax As Long) As Long Private Declare Function TranslateMessage Lib "user32.dll" _ (ByRef lpMsg As MSG) As Long Private Declare Function DispatchMessage Lib "user32.dll" Alias "DispatchMessageA" _ (ByRef lpMsg As MSG) As Long Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" _ (ByVal dwExStyle As Long, _ ByVal lpClassName As String, _ ByVal lpWindowName As String, _ ByVal dwStyle As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal nWidth As Long, _ ByVal nHeight As Long, _ ByVal hWndParent As Long, _ ByVal hMenu As Long, _ ByVal hInstance As Long, _ ByVal lpParam As Long) As Long Private Declare Function DestroyWindow Lib "user32.dll" _ (ByVal hwnd As Long) As Long Private Type BITMAPFILEHEADER bfType As Integer bfSize As Long bfReserved1 As Integer bfReserved2 As Integer bfOffBits As Long End Type Private Type BITMAPINFOHEADER biSize As Long biWidth As Long biHeight As Long biPlanes As Integer biBitCount As Integer biCompression As Long biSizeImage As Long biXPelsPerMeter As Long biYPelsPerMeter As Long biClrUsed As Long biClrImportant As Long End Type Private Type RGBQUAD rgbBlue As Byte rgbGreen As Byte rgbRed As Byte rgbReserved As Byte End Type Private Type POINTAPI x As Long y As Long End Type Private Type MSG hwnd As Long message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type Private Const GHND = 66 '---------------------------- ' Declaration for this Module '---------------------------- Private m_tAppID As TW_IDENTITY Private m_tSrcID As TW_IDENTITY Private m_lHndMsgWin As Long Public Enum TWAIN_MDL_COLOURTYPE BW = 0 ' TWPT_BW GREY = 1 ' TWPT_GRAY rgb = 2 ' TWPT_RGB End Enum Private Enum TWAIN_MDL_CAPABILITY XFERCOUNT = 1 ' CAP_XFERCOUNT PIXELTYPE = 257 ' ICAP_PIXELTYPE INDICATORS = 4107 ' CAP_INDICATORS UICONTROLLABLE = 4110 ' CAP_UICONTROLLABLE PHYSICALWIDTH = 4369 ' ICAP_PSYSICALWIDTH PHYSICALHEIGHT = 4370 ' ICAP_PSYSICALHEIGHT XRESOLUTION = 4376 ' ICAP_XRESOLUTION YRESOLUTION = 4377 ' ICAP_YRESOLUTION BITDEPTH = 4395 ' ICAP_BITDEPTH End Enum Private Enum TWAIN_MDL_ITEMYPE INT16 = 1 ' TW_INT16 short UINT16 = 4 ' TW_UINT16 unsigned short BOOL = 6 ' TW_BOOL unsigned short FIX32 = 7 ' TW_FIX32 structure End Enum Public Function TransferWithoutUI(ByVal sngResolution As Single, _ ByVal tColourType As TWAIN_MDL_COLOURTYPE, _ ByVal sngImageLeft As Single, _ ByVal sngImageTop As Single, _ ByVal sngImageRight As Single, _ ByVal sngImageBottom As Single, _ ByVal sBMPFileName As String) As Long '---------------------------------------------------------------------------- ' Function transfers one image from Twain data source without showing ' the data source user interface (silent transfer). ' ' Input values ' - sngResolution (Single) - resolution of the image in DPI ' (dots per inch) ' - tColourType (UDT) - colour depth of the imaged - monochromatic (BW), ' colours of grey (GREY), full colours (COLOUR) ' - sngImageLeft, sngImageTop, sngImageRight, sngImageBottom (Single) - ' values determine the rectangle on the scanner glass that will ' be scanned (default units are inches) - if you set Right and Bottom ' values to 0, the module sets maximum values the scanner driver allows ' (the bottom right corner of the scanner glass) ' - sBMPFileName (String) - the file name of the saved image ' ' Function returns 0 if OK, 1 if an error occurs '---------------------------------------------------------------------------- ' TransferWithoutUI(300, rgb, 0, 0, 8.3, 11.7,"D:\jj2.bmp") ' 'Dim lRtn As Long 'lRtn = mdlTwain.TransferWithoutUI(200, GREY, 0, 0, 0, 0,"noui_grey.bmp") ' Dim lRtn As Long Dim lTmp As Long Dim blTwainOpen As Boolean Dim lhDIB As Long On Local Error GoTo ErrPlace '------------------------------- ' Open Twain Data Source Manager '------------------------------- lRtn = OpenTwainDSM() If lRtn Then GoTo ErrPlace blTwainOpen = True '----------------------- ' Open Twain Data Source '----------------------- lRtn = OpenTwainDS() If lRtn Then GoTo ErrPlace '----------------------------------------------------------- ' Set all important attributes of the image and the transfer '----------------------------------------------------------- '---------------------------------------------------------------------- ' Set image size and position ' If sngImageRight or sngImageBottom is 0 put physical width and height ' of the scanner into these values '---------------------------------------------------------------------- If (sngImageRight = 0) Or (sngImageBottom = 0) Then lRtn = TwainGetOneValue(PHYSICALWIDTH, sngImageRight) If lRtn Then GoTo ErrPlace lRtn = TwainGetOneValue(PHYSICALHEIGHT, sngImageBottom) If lRtn Then GoTo ErrPlace End If lRtn = SetImageSize(sngImageLeft, sngImageTop, sngImageRight, sngImageBottom) If lRtn Then GoTo ErrPlace '----------------------------------------------- ' Set the image resolution in DPI - both X and Y '----------------------------------------------- lRtn = TwainSetOneValue(XRESOLUTION, FIX32, sngResolution) If lRtn Then GoTo ErrPlace lRtn = TwainSetOneValue(YRESOLUTION, FIX32, sngResolution) If lRtn Then GoTo ErrPlace '-------------------------- ' Set the image colour type '-------------------------- lRtn = TwainSetOneValue(PIXELTYPE, UINT16, tColourType) If lRtn Then GoTo ErrPlace '---------------------------------------------------------------- ' If the colour type is fullcolour, set the bitdepth of the image ' - 24 bits, 32 bits, ... '---------------------------------------------------------------- If tColourType = rgb Then lRtn = TwainSetOneValue(BITDEPTH, UINT16, 24) '--------------------------------------------------- ' Set number of images you want to transfer (just 1) '--------------------------------------------------- lRtn = TwainSetOneValue(XFERCOUNT, INT16, 1) If lRtn Then GoTo ErrPlace '---------------------------------------------------- ' TRANSFER the image with UI disabled. ' If successful, lhDIB is filled with handle to DIB '---------------------------------------------------- lRtn = TwainTransfer(False, lhDIB) If lRtn Then GoTo ErrPlace '------------------ ' Close Data Source '------------------ lRtn = CloseTwainDS() If lRtn Then GoTo ErrPlace '-------------------------- ' Close Data Source Manager '-------------------------- lRtn = CloseTwainDSM() If lRtn Then GoTo ErrPlace blTwainOpen = False '---------------------------------- ' Save DIB handle into the BMP file '---------------------------------- lRtn = SaveDIBToFile(lhDIB, sBMPFileName) If lRtn Then GoTo ErrPlace TransferWithoutUI = 0 Exit Function ErrPlace: If lhDIB Then lRtn = GlobalFree(lhDIB) If blTwainOpen Then lRtn = CloseTwainDS(): lRtn = CloseTwainDSM() TransferWithoutUI = 1 End Function Public Function TransferWithUI(ByVal sBMPFileName As String) As Long '------------------------------------------------------------------- ' Function transfers one image from Twain data source using the data ' source user interface to set image attributes. ' ' Input values ' - sBMPFileName (String) - the file name of the saved image ' ' Function returns 0 if OK, 1 if an error occurs '------------------------------------------------------------- Dim lRtn As Long Dim blTwainOpen As Boolean Dim lhDIB As Long On Local Error GoTo ErrPlace '------------------------------- ' Open Twain Data Source Manager '------------------------------- lRtn = OpenTwainDSM() If lRtn Then GoTo ErrPlace blTwainOpen = True '----------------------- ' Open Twain Data Source '----------------------- lRtn = OpenTwainDS() If lRtn Then GoTo ErrPlace '---------------------------------------------------- ' TRANSFER the image with UI enabled. ' If successful, lhDIB is filled with handle to DIB '---------------------------------------------------- lRtn = TwainTransfer(True, lhDIB) If lRtn Then GoTo ErrPlace '------------------ ' Close Data Source '------------------ lRtn = CloseTwainDS() If lRtn Then GoTo ErrPlace '-------------------------- ' Close Data Source Manager '-------------------------- lRtn = CloseTwainDSM() If lRtn Then GoTo ErrPlace blTwainOpen = False '---------------------------------- ' Save DIB handle into the BMP file '---------------------------------- lRtn = SaveDIBToFile(lhDIB, sBMPFileName) If lRtn Then GoTo ErrPlace TransferWithUI = 0 Exit Function ErrPlace: If lhDIB Then lRtn = GlobalFree(lhDIB) If blTwainOpen Then lRtn = CloseTwainDS(): lRtn = CloseTwainDSM() TransferWithUI = 1 End Function Public Function PopupSelectSourceDialog() As Long '------------------------------------------------------------------ ' Function shows the Twain dialog for selecting default data source ' ' Function returns 0 if OK, 1 if an error occurs '------------------------------------------------------------------ Dim iRtn As Integer Dim lRtn As Long On Local Error GoTo ErrPlace '------------------------------- ' Open Twain Data Source Manager '------------------------------- lRtn = OpenTwainDSM() If lRtn Then GoTo ErrPlace '---------------------------------------------------- ' Popup "Select source" dialog ' DG_CONTROL, DAT_IDENTITY, MSG_USERSELECT '---------------------------------------------------- iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_IDENTITY, _ MSG_USERSELECT, m_tSrcID) If iRtn <> TWRC_SUCCESS Then lRtn = CloseTwainDSM() GoTo ErrPlace End If '-------------------------------- ' Close Twain Data Source Manager '-------------------------------- lRtn = CloseTwainDSM() If lRtn Then GoTo ErrPlace PopupSelectSourceDialog = 0 Exit Function ErrPlace: PopupSelectSourceDialog = 1 End Function Private Function OpenTwainDSM() As Long Dim iRtn As Integer On Local Error GoTo ErrPlace '---------------------------------------------------- ' Create window that will receive all TWAIN messages ' Message loop can be found in TwainTransfer function '---------------------------------------------------- m_lHndMsgWin = CreateWindowEx(0&, "#32770", "TWAIN_MSG_WINDOW", 0&, _ 10&, 10&, 150&, 50&, 0&, 0&, 0&, 0&) If m_lHndMsgWin = 0 Then GoTo ErrPlace '------------------------------------------------------------ ' Introduce yourself to TWAIN - MajorNum, MinorNum, Language, ' Country, Manufacturer, ProductFamily, ProductName, etc. '------------------------------------------------------------ Call ZeroMemory(VarPtr(m_tAppID), Len(m_tAppID)) With m_tAppID .Version.MajorNum = 1 .Version.Language = TWLG_CZECH .Version.Country = TWCY_CZECHOSLOVAKIA .ProtocolMajor = TWON_PROTOCOLMAJOR .ProtocolMinor = TWON_PROTOCOLMINOR .SupportedGroups1 = DG_CONTROL Or DG_IMAGE End With Call CopyMemory(VarPtr(m_tAppID.Manufacturer(1)), _ StrPtr(StrConv("LMik", vbFromUnicode)), _ Len("LMik")) Call CopyMemory(VarPtr(m_tAppID.ProductFamily(1)), _ StrPtr(StrConv("VB Module", vbFromUnicode)), _ Len("VB Module")) Call CopyMemory(VarPtr(m_tAppID.ProductName(1)), _ StrPtr(StrConv("VB Module for TWAIN", vbFromUnicode)), _ Len("VB Module for TWAIN")) '-------------------------------------- ' Open Data Source Manager ' DG_CONTROL, DAT_PARENT, MSG_OPENDSM '-------------------------------------- iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_PARENT, MSG_OPENDSM, _ m_lHndMsgWin) If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace OpenTwainDSM = 0 Exit Function ErrPlace: OpenTwainDSM = 1 End Function Private Function OpenTwainDS() As Long Dim iRtn As Integer On Local Error GoTo ErrPlace '---------------------------------------------------------------------- ' Open Data Source ' DG_CONTROL, DAT_IDENTITY, MSG_OPENDS ' ' The default data source is opened. If you want user to select the new ' default one, call public function PopupSelectSourceDialog. '---------------------------------------------------------------------- Call ZeroMemory(VarPtr(m_tSrcID), Len(m_tSrcID)) iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_IDENTITY, MSG_OPENDS, _ m_tSrcID) If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace OpenTwainDS = 0 Exit Function ErrPlace: OpenTwainDS = 1 End Function Private Function CloseTwainDS() As Long Dim iRtn As Integer On Local Error GoTo ErrPlace '---------------------------------------- ' Close Data Source ' DG_CONTROL, DAT_IDENTITY, MSG_CLOSEDS '---------------------------------------- iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_IDENTITY, _ MSG_CLOSEDS, m_tSrcID) If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace CloseTwainDS = 0 Exit Function ErrPlace: CloseTwainDS = 1 End Function Private Function CloseTwainDSM() As Long Dim lRtn As Long Dim iRtn As Integer On Local Error GoTo ErrPlace '--------------------------------------- ' Close Data Source Manager ' DG_CONTROL, DAT_PARENT, MSG_CLOSEDSM '--------------------------------------- iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_PARENT, MSG_CLOSEDSM, _ m_lHndMsgWin) If iRtn <> TWRC_SUCCESS Then lRtn = DestroyWindow(m_lHndMsgWin) GoTo ErrPlace End If '--------------------------- ' Destroy the message window '--------------------------- lRtn = DestroyWindow(m_lHndMsgWin) If lRtn = 0 Then GoTo ErrPlace CloseTwainDSM = 0 Exit Function ErrPlace: CloseTwainDSM = 1 End Function Private Function SetImageSize(ByRef sngLeft As Single, _ ByRef sngTop As Single, _ ByRef sngRight As Single, _ ByRef sngBottom As Single) As Long Dim tImageLayout As TW_IMAGELAYOUT Dim lRtn As Long Dim iRtn As Integer On Local Error GoTo ErrPlace '------------------------------------------------------------------- ' Set the size of the image - in default units ' DG_IMAGE, DAT_IMAGELAYOUT, MSG_SET ' ' If you do not select any units the INCHES are selected as default. ' The values of Single type are converted into TWAIN TW_FIX32. '------------------------------------------------------------------- lRtn = FloatToFix32(sngLeft, tImageLayout.Frame.Left) If lRtn Then GoTo ErrPlace lRtn = FloatToFix32(sngTop, tImageLayout.Frame.Top) If lRtn Then GoTo ErrPlace lRtn = FloatToFix32(sngRight, tImageLayout.Frame.Right) If lRtn Then GoTo ErrPlace lRtn = FloatToFix32(sngBottom, tImageLayout.Frame.Bottom) If lRtn Then GoTo ErrPlace iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_IMAGE, DAT_IMAGELAYOUT, MSG_SET, _ tImageLayout) If (iRtn <> TWRC_SUCCESS) And (iRtn <> TWRC_CHECKSTATUS) Then GoTo ErrPlace SetImageSize = 0 Exit Function ErrPlace: SetImageSize = 1 End Function Public Function TwainTransfer(ByRef blShowUI As Boolean, _ ByRef lDIBHandle As Long) As Long Dim tUI As TW_USERINTERFACE Dim tPending As TW_PENDINGXFERS Dim lhDIB As Long Dim tEvent As TW_EVENT Dim tMSG As MSG Dim lRtn As Long Dim iRtn As Integer On Local Error GoTo ErrPlace '--------------------------------------------- ' Set tUI.ShowUI to 1 (show UI) or 0 (hide UI) '--------------------------------------------- With tUI .ShowUI = IIf(blShowUI = True, 1, 0) .ModalUI = 1 .hParent = m_lHndMsgWin End With '---------------------------------------------- ' Enable Data Source User Interface ' DG_CONTROL, DAT_USERINTERFACE, MSG_ENABLEDS '---------------------------------------------- iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, _ MSG_ENABLEDS, tUI) If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace '----------------------------------------------------------------- ' Process events in the message loop ' DG_CONTROL, DAT_EVENT, MSG_PROCESSEVENT ' ' There are two messages we are interested in in this message loop ' - MSG_XFERREADY - the data source is ready to transfer ' - MSG_CLOSEDSREQ - the data source requests to close itself '----------------------------------------------------------------- While GetMessage(tMSG, 0&, 0&, 0&) Call ZeroMemory(VarPtr(tEvent), Len(tEvent)) tEvent.pEvent = VarPtr(tMSG) iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_EVENT, _ MSG_PROCESSEVENT, tEvent) Select Case tEvent.TWMessage Case MSG_XFERREADY GoTo MSGGET Case MSG_CLOSEDSREQ GoTo MSGDISABLEDS End Select lRtn = TranslateMessage(tMSG) lRtn = DispatchMessage(tMSG) Wend MSGGET: '---------------------------------------------------- ' Start transfer ' DG_IMAGE, DAT_IMAGENATIVEXFER, MSG_GET ' ' If transfer is successful you get the handle to DIB '---------------------------------------------------- iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_IMAGE, DAT_IMAGENATIVEXFER, _ MSG_GET, lhDIB) If iRtn <> TWRC_XFERDONE Then iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_PENDINGXFERS, _ MSG_ENDXFER, tPending) iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, _ MSG_DISABLEDS, tUI) GoTo ErrPlace End If '-------------------------------------------- ' End transfer ' DG_CONTROL, DAT_PENDINGXFERS, MSG_ENDXFER '-------------------------------------------- iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_PENDINGXFERS, _ MSG_ENDXFER, tPending) If iRtn <> TWRC_SUCCESS Then iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, _ MSG_DISABLEDS, tUI) GoTo ErrPlace End If MSGDISABLEDS: '----------------------------------------------- ' Disable Data Source ' DG_CONTROL, DAT_USERINTERFACE, MSG_DISABLEDS '----------------------------------------------- iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, _ MSG_DISABLEDS, tUI) If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace lDIBHandle = lhDIB TwainTransfer = 0 Exit Function ErrPlace: If lhDIB Then lRtn = GlobalFree(lhDIB) lDIBHandle = 0 TwainTransfer = 1 End Function Private Function SaveDIBToFile(ByRef lhDIB As Long, _ ByRef sFileName As String) As Long '--------------------------------------------------------------------------- ' Function saves the handle to DIB (device independent bitmap) into BMP file '--------------------------------------------------------------------------- Dim tBFH As BITMAPFILEHEADER Dim tBIH As BITMAPINFOHEADER Dim tRGB As RGBQUAD Dim lpDIB As Long Dim lDIBSize As Long Dim bDIBits() As Byte Dim iFileNum As Integer Dim lRtn As Long On Local Error GoTo ErrPlace If sFileName = "" Then GoTo ErrPlace If Dir(sFileName, vbNormal Or vbHidden Or vbSystem) <> "" Then Call SetAttr(sFileName, vbNormal) Call Kill(sFileName) End If lpDIB = GlobalLock(lhDIB) If lpDIB = 0 Then GoTo ErrPlace Call CopyMemory(VarPtr(tBIH), lpDIB, Len(tBIH)) lDIBSize = Len(tBIH) + (tBIH.biClrUsed * Len(tRGB)) + _ (((tBIH.biWidth * tBIH.biBitCount + 31) \ 32) * 4 * tBIH.biHeight) ReDim bDIBits(1 To lDIBSize) As Byte Call CopyMemory(VarPtr(bDIBits(1)), lpDIB, lDIBSize) lRtn = GlobalUnlock(lhDIB) lRtn = GlobalFree(lhDIB) lhDIB = 0 With tBFH .bfType = 19778 ' "BM" .bfSize = Len(tBFH) + lDIBSize .bfOffBits = Len(tBFH) + Len(tBIH) + (tBIH.biClrUsed * Len(tRGB)) End With iFileNum = FreeFile Open sFileName For Binary As #iFileNum Put #iFileNum, , tBFH Put #iFileNum, , bDIBits() Close #iFileNum SaveDIBToFile = 0 Exit Function ErrPlace: lRtn = GlobalUnlock(lhDIB) lRtn = GlobalFree(lhDIB) lhDIB = 0 SaveDIBToFile = 1 End Function Private Function TwainSetOneValue(ByVal Cap As TWAIN_MDL_CAPABILITY, _ ByVal ItemType As TWAIN_MDL_ITEMYPE, _ ByRef Item As Variant) As Long '----------------------------------------------------------------------- ' There are four types of containers that TWAIN defines for capabilities ' (TW_ONEVALUE, TW_ARRAY, TW_RANGE and TW_ENUMERATION) ' This module deals with one of them only - TW_ONEVALUE (single value) ' To set some capability you have to fill TW_ONEVALUE fields and use ' the triplet DG_CONTROL DAT_CAPABILITY MSG_SET ' The macros that convert some data types are used here as well '----------------------------------------------------------------------- On Local Error GoTo ErrPlace Dim tCapability As TW_CAPABILITY Dim tOneValue As TW_ONEVALUE Dim lhOneValue As Long Dim lpOneValue As Long Dim lRtn As Long Dim iRtn As Integer Dim tFix32 As TW_FIX32 Dim iTmp As Integer tCapability.ConType = TWON_ONEVALUE tCapability.Cap = Cap tOneValue.ItemType = ItemType Select Case ItemType Case INT16 tOneValue.Item1 = CInt(Item) Case UINT16, BOOL If ToUnsignedShort(CLng(Item), iTmp) Then GoTo ErrPlace Call CopyMemory(VarPtr(tOneValue.Item1), VarPtr(iTmp), 2&) Case FIX32 If FloatToFix32(CSng(Item), tFix32) Then GoTo ErrPlace Call CopyMemory(VarPtr(tOneValue.Item1), VarPtr(tFix32), 4&) End Select lhOneValue = GlobalAlloc(GHND, Len(tOneValue)) lpOneValue = GlobalLock(lhOneValue) Call CopyMemory(lpOneValue, VarPtr(tOneValue), Len(tOneValue)) lRtn = GlobalUnlock(lhOneValue) tCapability.hContainer = lhOneValue iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_CAPABILITY, MSG_SET, _ tCapability) If iRtn <> TWRC_SUCCESS Then lRtn = GlobalFree(lhOneValue) GoTo ErrPlace End If lRtn = GlobalFree(lhOneValue) TwainSetOneValue = 0 Exit Function ErrPlace: TwainSetOneValue = 1 End Function Private Function TwainGetOneValue(ByVal Cap As TWAIN_MDL_CAPABILITY, _ ByRef Item As Variant) As Long '----------------------------------------------------------------------- ' There are four types of containers that TWAIN defines for capabilities ' (TW_ONEVALUE, TW_ARRAY, TW_RANGE and TW_ENUMERATION) ' This module deals with one of them only - TW_ONEVALUE (single value) ' To get some capability you have to fill TW_ONEVALUE fields and use ' the triplet DG_CONTROL DAT_CAPABILITY MSG_GET ' The macros that convert some data types are used here as well '----------------------------------------------------------------------- On Local Error GoTo ErrPlace Dim tCapability As TW_CAPABILITY Dim tOneValue As TW_ONEVALUE Dim tFix32 As TW_FIX32 Dim lpOneValue As Long Dim lRtn As Long Dim iRtn As Integer tCapability.ConType = TWON_ONEVALUE tCapability.Cap = Cap iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_CAPABILITY, MSG_GET, _ tCapability) If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace lpOneValue = GlobalLock(tCapability.hContainer) Call CopyMemory(VarPtr(tOneValue), lpOneValue, Len(tOneValue)) lRtn = GlobalUnlock(tCapability.hContainer) lRtn = GlobalFree(tCapability.hContainer) Select Case tOneValue.ItemType Case INT16 Item = tOneValue.Item1 Case UINT16, BOOL Item = FromUnsignedShort(tOneValue.Item1) Case FIX32 Call CopyMemory(VarPtr(tFix32), VarPtr(tOneValue.Item1), 4&) Item = Fix32ToFloat(tFix32) End Select TwainGetOneValue = 0 Exit Function ErrPlace: TwainGetOneValue = 1 End Function Private Function ToUnsignedShort(ByRef lSrc As Long, _ ByRef iDst As Integer) As Long '------------------------------------------------------------------------ ' Sets number ranging from 0 to 65535 into 2-byte VB Integer ' (useful for communicating with other dll that uses unsigned data types) ' ' Function returns 0 is OK, 1 if an error occurs '------------------------------------------------------------------------ On Local Error GoTo ErrPlace If (lSrc < 0) Or (lSrc > 65535) Then GoTo ErrPlace Call CopyMemory(VarPtr(iDst), VarPtr(lSrc), 2&) ' Another way 'iDst = IIf(lSrc > 32767, lSrc - 65536, lSrc) ToUnsignedShort = 0 Exit Function ErrPlace: ToUnsignedShort = 1 End Function Private Function FromUnsignedShort(ByRef iSrc As Integer) As Long '------------------------------------------------------------------------ ' Gets the 2-byte unsigned number from VB Integer data type ' (useful for communicating with other dll that uses unsigned data types) ' ' Function returns unsigned 2-byte value (in VB Long type) '------------------------------------------------------------------------ Dim lTmp As Long Call CopyMemory(VarPtr(lTmp), VarPtr(iSrc), 2&) ' Another way 'lTmp = IIf(iSrc < 0, iSrc + 65536, iSrc) FromUnsignedShort = lTmp End Function Private Function ToUnsignedLong(ByRef sngSrc As Single, _ ByRef lDst As Long) As Long '------------------------------------------------------------------------ ' Sets number ranging from 0 to 4294967295 into 4-byte VB Long ' (useful for communicating with other dll that uses unsigned data types) ' ' Function returns 0 is OK, 1 if an error occurs '------------------------------------------------------------------------ On Local Error GoTo ErrPlace If (sngSrc < 0) Or (sngSrc > 4294967295#) Then GoTo ErrPlace lDst = IIf(sngSrc > 2147483647, sngSrc - 4294967296#, sngSrc) ToUnsignedLong = 0 Exit Function ErrPlace: ToUnsignedLong = 1 End Function Private Function FromUnsignedLong(ByRef lSrc As Long) As Single '------------------------------------------------------------------------ ' Gets the 4-byte unsigned number from VB Long data type ' (useful for communicating with other dll that uses unsigned data types) ' ' Function returns unsigned 4-byte value (in VB Single type) '------------------------------------------------------------------------ Dim sngTmp As Single sngTmp = IIf(lSrc < 0, lSrc + 4294967296#, lSrc) FromUnsignedLong = sngTmp End Function Private Function Fix32ToFloat(ByRef tFix32 As TW_FIX32) As Single '---------------------------------------------------------------- ' Converts TWAIN TW_FIX32 data structure into VB Single data type ' (needed for communicating with TWAIN) ' ' Function returns floating-point number in VB Single data type '---------------------------------------------------------------- Dim sngTmp As Single sngTmp = tFix32.Whole + CSng(FromUnsignedShort(tFix32.Frac) / 65536) Fix32ToFloat = sngTmp End Function Private Function FloatToFix32(ByRef sngSrc As Single, _ ByRef tFix32 As TW_FIX32) As Long '---------------------------------------------------------------- ' Converts VB Single data type into TWAIN TW_FIX32 data structure ' (needed for communicating with TWAIN) ' ' Function returns 0 is OK, 1 if an error occurs '---------------------------------------------------------------- On Local Error GoTo ErrPlace tFix32.Whole = CInt(Fix(sngSrc)) Call ToUnsignedShort(CLng(sngSrc * 65536) And 65535, tFix32.Frac) FloatToFix32 = 0 Exit Function ErrPlace: FloatToFix32 = 1 End Function . جعفر

استاذ محمد حسن حضرتك ممكن تتواصل معايا أخي الكريم هاني السلام عليكم ورحمة الله وبركاته ...أتشرف بالتواصل معكم ولكن اسمع عذري وبعدها قرر: الحقيقة التي يعلمها الكثيرون من الأساتذة الكرام أنني مبتدئ في هذا البحر الزاخر ...وما قدمني بينهم إلا عاطفة الأبوة والأخوة التي أحسها تجاههم .. أما إن كنت تريد معرفة العلم على أصوله فاطرق أبواب أربابه ولا تمل وهم لن يبخلوا لأنه مجال لا مجال للبخل به ....وهل يرضى أن يحوز على رضى الناس ويغضب ربه بكتمان العلم وكيف سينتقل العلم إلى الأجيال القادمة في حال كتمانه. والسلام عليكم ورحمة الله وبركاته.

رائعه المحترم ياسر خليل كود لتحويل درجات الطلاب لمستويات ( تقديرات ) .. تصلح للترم الاول Option Explicit ' هذا الكود من روائع المحترم ياسر خليل 'الهدف من الكود هو تحويل درجات الطلاب الى مستويات ( تقديرات ) 'تم عمل هذا الكود بتاريخ 12/1/2017 Function Level(Mark As Variant, OutOf As Long) As String If IsNumeric(Mark) Then Mark = Mark / OutOf Select Case Mark Case Is <= 0 Level = "" Case Is < 0.5 Level = "دون المستوى" Case Is < 0.65 Level = "مقبول" Case Is < 0.75 Level = "جيد" Case Is < 0.85 Level = "جيد جداً" Case Is <= 1 Level = "ممتاز" Case Else Level = "" End Select Else Select Case Mark Case "غ" Level = "غ" Case "صفر" Level = "دون المستوى" Case "واحد" Level = "دون المستوى" Case "اثنان" Level = "دون المستوى" Case "ثلاثة" Level = "دون المستوى" Case Else Level = "" End Select End If End Function ======================================= Level UDF Using Select Case YasserKhalil ExcelLover.rar جزاه الله عنا كل خير

جزاك الله خيرا استاذ ياسر خليل

وعليكم السلام اسمح لي اشرح التالي ، عن حقل الاسم fName : اذا جعلت شرط الاسم: 1. وكتبت في بحث النموذج جم ، فهذا سيعطيك الاسماء التي بها الحروف جم ، مثل (جمال ، جميل ، جميله ، جمعه ، اجمل ... ) ، والاسوأ اذا تبحث في الحقل ID عن الرقم 1 ، فهذا سيعطيك الارقام التي بها الرقم 1 ، مثل (1 ، 11 ، 120 ، 213 ، 115265 .... ) ، 2. واذا في النموذج عندك مربع سرد وتحرير ، وفيه اسماء الاشخاص ، وعندك اختيار باسم All ، ولما تريد اختيار All فانك تريد اعطائك جميع الاسماء ، 3. بينما اذا اردت اختيار اسم معين ، فالطريقة هكذا ، 4. بينما اذا اردت ترك حقل الاسم فاضي ، فالطريقة هذه تعطيك جميع الاسماء: 1 Like "*" & [forms]![frm_Main]![fName] & "*" Like "*" & [forms]![frm_Main]![ID] & "*" 2 Like IIf([forms]![frm_Main]![fName]='All',"*","*" & [forms]![frm_Main]![fName] & "*") 3 [forms]![frm_Main]![fName] 4 iif(len([forms]![frm_Main]![fName] & '')=0,[fName],[forms]![frm_Main]![fName]) . جعفر

السلام عليكم، اليك هذه المحاولة. جلب وتسجيل بيانات من مصنف مغلق_ن001.rar

قصدت من سؤالي هو محاولة معالجة الكود الاول تفضل الكود الآخر ويعمل على اكمل وجه db3.rar

وعليكم السلام أخوي ابوخليل ما استغرب ، وما خليت بالي على هذه القضية المرفق فيه ملف vbs واللي عادة يكون فيه برنامج مخرب للكمبيوتر ، وفيه برنامج exe كذلك واللي ممكن يخرب الكمبيوتر!! انا جتني هذه الرسالة: . فضغطت على Keep وتم التنزيل سأعمل مجموعة محاولات ، وعلى اساسها سارفع المرفق الصحيح جعفر توصلت الى المرفق الصحيح ، فسأرفعه الان الى رابط الموضوع الاصلي: http://www.officena.net/ib/topic/66836-تشغيل-برنامج-الاكسس-في-اي-مجلد-،-وبدون-رسائل-الأمان/ جعفر

السلام عليكم أخوي أبوخليل انت تطوعت للتجربة وضعت موضوع خاص على هذا الرابط: http://www.officena.net/ib/topic/66836-تشغيل-برنامج-الاكسس-في-اي-مجلد-،-وبدون-رسائل-الأمان/ جعفر

السلام عليكم اخوي ابوخليل كلامك جميل وواقعي بحثت في هذا الموضوع ، واتضح ان هناك طريقة بديلة تتماشى مع "المجلد الموثوق به" ، وهي إضافة "مجلد موثوق به" عن طريق ملف vbs (طبعا استعماله يكون مثل ما تفضلت ، عند تحزيم البرنامج) ، وعليه تستطيع ان تنصب برنامجك فيه وتنحلّ المشكلة هناك الكثير من الاكواد المتوفرة لهذا الغرض يعني بدل تخفيض مستوى الامان ، نعمل مجلد موثوق به جعفر

السلام عليكم اخي العزيز اشكر اهتمامك بمشكلتي لقد جربت الطريقة وحلت المشكلة مع الشكر الجزيل

السلام عليكم أخي محمد انا لن اتطرق لطريقة عمل النموذج الجديد ، "لأننا" لم نلحظ المشكلة في النموذج الاصل ولكني دخلت في كود Combopn_AfterUpdate : pn = DLookup("pn", "code", "[pn]=forms!frm_dataentry!Combopn") size = DLookup("Size", "code", "[pn]=forms!frm_dataentry!Combopn") vendor = DLookup("Vendor", "code", "[pn]=forms!frm_dataentry!Combopn") Description = DLookup("Description", "code", "[pn]=forms!frm_dataentry!Combopn") Maxrl = DLookup("Maxrl", "code", "[pn]=forms!frm_dataentry!Combopn") Maxrlegyptair = DLookup("Maxrlegyptair", "code", "[pn]=forms!frm_dataentry!Combopn") ACType = DLookup("actype", "code", "[pn]=forms!frm_dataentry!Combopn") Pos = DLookup("pos", "code", "[pn]=forms!frm_dataentry!Combopn") BiasRadial = DLookup("biasradial", "code", "[pn]=forms!frm_dataentry!Combopn") code = DLookup("code", "code", "[pn]=forms!frm_dataentry!Combopn") لاحظت انك تنادي الجدول (اي تعمل استعلام للجدول) 10 مرات !! انا دائما لما اعمل برامجي ، اعمل البرنامج على اساس انه سيكون عبارة عن جزئين ، الواجهة FE ، والجداول BE ، وان الجداول BE ، ستكون في شبكة ، وان الواجهة FE ستكون لأكثر من مستخدم. لهذا السبب ، فيجب ان نقلل الزحمة في الشبكة ، وذلك بتقليل زيارة/استعلام الجداول قدر الإمكان ، وعند كل زيارة ، يجب ان نأخذ اكبر كمية من البيانات المطلوبة ، ثم نتعامل معها محليا في FE. لذلك ، فانا هنا اعطيك احد البدائل (والتي لا يعرفها الكثير ، لأنها تعمل على الاكسس 2003 فما فوق) ، فالكود التالي ، يقوم بزيارة/استعلام الجدول عن طريق DLookup مرة واحدة ، ويأخذ 10 بيانات مرة واحدة ، فلذا يمكن ان يستبدل كودك اعلاه: Dim x() As String A = Nz(DLookup("[pn] & '|' & [Size] & '|' & [Vendor] & '|' & [Description] & '|' & [Maxrl] & '|' & [Maxrlegyptair] & '|' & [actype] & '|' & [pos] & '|' & [biasradial] & '|' & [code]", "code", "[pn]=forms!frm_dataentry!Combopn"),"|||||||||") 'ويمكن استعمال اي شيء بدل عن | فمثلا الفاصلة 'A حتى اذا لم هناك قيمة للمتغير Nz نستعمل الدالة 'عدد مرات وضع العلامة | في نهاية السطر ، يكون نفس عددها في المعادلة 'لهذا السبب نرى اننا وضعنا 9 منها في نهاية السطر x = Split(A, "|") ' For i = LBound(x) To UBound(x) ' Debug.Print x(i) ' Next i Me.pn = x(0) Me.size = x(1) Me.vendor = x(2) Me.Description = x(3) Me.Maxrl = x(4) Me.Maxrlegyptair = x(5) Me.ACType = x(6) Me.Pos = x(7) Me.BiasRadial = x(8) Me.code = x(9) جعفر

في البدايه من أراد البرنامج بالنسخة الأنجليزية فهو على الرابط التالي http://www.officena.net/ib/index.php?showtopic=16918 ( النسخة للتعامل باللغة العربية ) فكرة البرنامج وكيفية الأستخدام ستبدأ أولاً بتسجيل الأصناف الموجودة لديك في صفحة ( Items ) ملحوظه ( من يريد نسخه تقوم بالترقيم تلقائياً فليخبرني لأقوم بتصميمها ) رقم الموديل هام وستحتاجه عند إضافة صنف أو أخراجه من المستودع الآن وبعد تسجيل المنتجات التي لديك . توجه الي صفحة ( To Store ) والتي تعني أدخال الصنف للمستودع في خانة ( NO ) أدخل الرقم المتسلسل للصنف كما هو مسجل في صفحة ( Items ) وستلاحظ أن بياناته تظهر أمامك ويبقى تسجيل العدد وتاريخ الأدخال عندما تريد إخراج صنف من المستودع ستذهب الي صفحة Out Of Store وستقوم أيضاً بإدخال رقم الصنف وستلاحظ أنه تظهر أمامك الآن الموديل والوصف والكميه المدخله من البدايه والرصيد الباقي لديك قم بأدخال الكميه المراد إخراجها وستظهر لك رساله توضيحيه بالرصيد الباقي . ولا تقلق إن أخطأت في كتابة الكميه بزياده عن الموجود في المستودع فالبرنامج لن يقبل ذلك وستظهر رساله أيضاً بذلك يمكنك طباعة تقرير مستقل لصنف بكميته وعدد مرات الأدخال والأخراج من المستودع يمكنك طباعة ورقه برصيد المستودع لكامل الأصناف ولكن عليك الضغط على زر الطباعه المخصص لذلك في الصفحه لتجنب طباعة البيانات الفارغه . يوجد زر بحث في صفحة الأصناف لكي يسهل عليك الوصول الي رقم أي صنف تريد نعرفته سريعاً ملحوظه : إذا أدخلت عدد معين لصنف ما ... وتريد أضافة عدد آخر فأنت لست بحاجه للذهاب لرصيدك السابق وتعديله ولكن يمكن تسجيل العدد الجديد برقم الصنف وسيتم أضافته للسابق مقترحاتكم تهمنا فلا تبخلوا بها علينا بالتوفيق Store_Arabic.zip

* أخي خبور * جرب كتابة الأسم التالي ( حسام الدين عبد المنعم السيد )

لا أعرف كيف أشكركم على هذه الدعوات الجميله