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

السلام عليكم الاخت الفاضلة المهندسة / سما محمد اتفق معكي فعلا في رأيك بانه لا يوجد مستحيل هنا مع خبراؤنا واساتذتنا العظام واليكي اختي الكريمة الحل في المرفق وهو كود للقدير الرائع / جعفر طرباق ... جزاه الله خيرا يقوم بعمل ما تريديه بالضبط وتم تنفيذه علي ملفك ومرفق ملفك ... وملف للاستاذ / جعفر به الاكواد واليكم الكود ايضا جزاكي الله خيرا فورم شفاف+.rar TransparentForm.rar Option Explicit Private Type POINTAPI X As Long Y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom 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 biRUsed As Long biRImportant As Long End Type Private Type BITMAPINFO_NoColors bmiHeader As BITMAPINFOHEADER End Type Private Type BITMAPFILEHEADER bfType As Integer bfSize As Long bfReserved1 As Integer bfReserved2 As Integer bfOffBits As Long End Type Private Type MemoryBitmap hdc As Long hBM As Long oldhDC As Long wid As Long hgt As Long bitmap_info As BITMAPINFO_NoColors End Type Private Declare Function CreateDIBSection Lib "gdi32" _ (ByVal hdc As Long, pBitmapInfo As BITMAPINFO_NoColors, _ ByVal un As Long, ByVal lplpVoid As Long, _ ByVal handle As Long, ByVal dw As Long) _ As Long Private Declare Function GetDIBits Lib "gdi32" _ (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal _ nStartScan As Long, ByVal nNumScans As Long, _ lpBits As Any, lpBI As BITMAPINFO_NoColors, _ ByVal wUsage As Long) _ As Long Private Declare Function FindWindow Lib "user32.dll" _ Alias "FindWindowA" _ (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Private Declare Function GetWindow Lib "user32.dll" _ (ByVal hwnd As Long, ByVal wCmd As Long) As Long Private Declare Function ClientToScreen Lib "user32.dll" _ (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long Private Declare Function GetDC Lib "user32.dll" _ (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32.dll" _ (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Function GetClientRect Lib "user32.dll" _ (ByVal hwnd As Long, ByRef lpRect As RECT) As Long Private Declare Function BitBlt Lib "gdi32" _ (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, _ ByVal hSrcDC As Long, ByVal xSrc As Long, _ ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32.dll" _ (ByVal hdc As Long) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" _ (ByVal hdc As Long, ByVal nWidth As Long, _ ByVal nHeight As Long) As Long Private Declare Function DeleteObject Lib "gdi32.dll" _ (ByVal hObject As Long) As Long Private Declare Function SelectObject Lib "gdi32.dll" _ (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function DeleteDC Lib "gdi32" _ (ByVal hdc As Long) As Long Private Declare Function GetSystemMetrics Lib "user32" _ (ByVal nIndex As Long) As Long Private Declare Function PrintWindow Lib "user32" _ (ByVal hwnd As Long, ByVal hdcBlt As Long, _ ByVal nFlags As Long) As Long Private Const PICTYPE_BITMAP = 1 Private Const DIB_RGB_COLORS = 0& Private Const BI_RGB = 0& Private Const SRCCOPY = &HCC0020 Private Const SM_CXSCREEN = 0 Private Const SM_CYSCREEN = 1 Private Const SM_CYBORDER = 6 Private Const SM_CYDLGFRAME = 8 Private WithEvents wb As Workbook Private Sub UserForm_Initialize() Set wb = ThisWorkbook Call Paint_UserForm End Sub Private Sub UserForm_Layout() Call Paint_UserForm End Sub Private Sub wb_SheetSelectionChange _ (ByVal Sh As Object, ByVal Target As Range) Call Paint_UserForm End Sub Private Sub Paint_UserForm() Dim tRect As RECT Dim tpt As POINTAPI Dim memory_bitmap As MemoryBitmap Dim frmDc As Long Dim memDc As Long Dim scrDc As Long Dim oldDc As Long Dim tempBmp As Long Dim frmHwnd As Long Dim frmClientWid As Long Dim frmClientHgt As Long Dim scrWid As Long Dim scrHgt As Long Dim X As Long Dim Y As Long frmHwnd = FindWindow(vbNullString, Me.Caption) frmDc = GetDC(frmHwnd) GetClientRect frmHwnd, tRect With tRect frmClientWid = .Right - .Left frmClientHgt = .Bottom - .Top End With scrWid = GetSystemMetrics(SM_CXSCREEN) scrHgt = GetSystemMetrics(SM_CYSCREEN) scrDc = GetDC(0) memDc = CreateCompatibleDC(scrDc) tempBmp = CreateCompatibleBitmap(scrDc, scrWid, scrHgt) oldDc = SelectObject(memDc, tempBmp) PrintWindow Application.hwnd, memDc, 1 memory_bitmap = _ MakeMemoryBitmap(memDc, frmClientWid, frmClientHgt) Call ClientToScreen(frmHwnd, tpt) X = tpt.X Y = tpt.Y BitBlt memory_bitmap.hdc, 0, 0, frmClientWid, frmClientHgt, _ memDc, X + 8, Y + GetSystemMetrics(SM_CYDLGFRAME) + _ GetSystemMetrics(SM_CYBORDER), SRCCOPY SaveMemoryBitmap memory_bitmap, Environ("Temp") & "\temp.bmp" Set Me.Picture = LoadPicture(Environ("Temp") & "\temp.bmp") ReleaseDC 0, scrDc ReleaseDC frmHwnd, frmDc SelectObject memDc, oldDc DeleteObject tempBmp DeleteObject memDc SelectObject memory_bitmap.hdc, memory_bitmap.oldhDC DeleteObject memory_bitmap.hBM DeleteDC memory_bitmap.hdc End Sub Private Function MakeMemoryBitmap _ (memDc As Long, wid As Long, hgt As Long) As MemoryBitmap Dim result As MemoryBitmap Dim bytes_per_scanLine As Long Dim pad_per_scanLine As Long result.hdc = CreateCompatibleDC(memDc) With result.bitmap_info.bmiHeader .biBitCount = 32 .biCompression = BI_RGB .biPlanes = 1 .biSize = Len(result.bitmap_info.bmiHeader) .biWidth = wid .biHeight = hgt bytes_per_scanLine = ((((.biWidth * .biBitCount) + _ 31) \ 32) * 4) pad_per_scanLine = bytes_per_scanLine - (((.biWidth _ * .biBitCount) + 7) \ 8) .biSizeImage = bytes_per_scanLine * Abs(.biHeight) End With result.hBM = CreateDIBSection( _ result.hdc, result.bitmap_info, _ DIB_RGB_COLORS, ByVal 0&, _ ByVal 0&, ByVal 0&) result.oldhDC = SelectObject(result.hdc, result.hBM) result.wid = wid result.hgt = hgt MakeMemoryBitmap = result End Function Private Sub SaveMemoryBitmap( _ memory_bitmap As MemoryBitmap, _ ByVal file_name As String _ ) Dim bitmap_file_header As BITMAPFILEHEADER Dim fnum As Integer Dim pixels() As Byte With bitmap_file_header .bfType = &H4D42 .bfOffBits = Len(bitmap_file_header) + _ Len(memory_bitmap.bitmap_info.bmiHeader) .bfSize = .bfOffBits + _ memory_bitmap.bitmap_info.bmiHeader.biSizeImage End With fnum = FreeFile Open file_name For Binary As fnum Put #fnum, , bitmap_file_header Put #fnum, , memory_bitmap.bitmap_info ReDim pixels(1 To 4, _ 1 To memory_bitmap.wid, _ 1 To memory_bitmap.hgt) GetDIBits memory_bitmap.hdc, memory_bitmap.hBM, _ 0, memory_bitmap.hgt, pixels(1, 1, 1), _ memory_bitmap.bitmap_info, DIB_RGB_COLORS Put #fnum, , pixels Close fnum End Sub

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاتة عندي هذا الكود ووضعتة في زر امر insert لادخال البيانات من الفورم 2 الى الشيت 1 (((( كود ترحيل بيانات ))))))) المطلوب عندي فورم3 اريد التعديل على هذا الكود -ليصبح عند فتح الفورم رقم3 يدخل البيانات في الشيت 3 (ايضا) مثل ماهو الحال في الفورم2 والشيت1 الكود هو شكرا لكم ننتظركم بفارغ الصبر ‫Warehouses Muu 2013 - نسخة.rar

السلام عليكم الاخ الكريم / كرتوتي طبعا بعد ردود الحبيب الاستاذ / ابو حنين فلا يوجد ردود ... جزاه الله خيرا وجزيل الشكر للاخ / حسين العصلوجي ... حيث انني معجب بردوده كثيرا ... جزاه الله خيرا وعلي حسب فهمي للطلب سنقوم بزيادة جزء بسيط علي الكود الخاص بـ Private Sub UserForm_activate() ليكون كالتالي Private Sub UserForm_activate() With Sheets("سجل البنك") For r = 2 To 12 ComboBox2.AddItem .Range("O" & r) If .Range("P" & r) <> "" Then ComboBox3.AddItem .Range("P" & r) ComboBox4.AddItem .Range("q" & r) End If Next r End With '======================= ' هذا هو الجزء المضاف للكود لعمل الترقيم التلقائي في الفورم في تكست بوكس 1 ActiveSheet.Select T = Cells(Rows.Count, 1).End(xlUp).Row TextBox1 = Val(Cells(T, 1)) + 1 End Sub واليك الملف المرفق به التعديل المطلوب ... ارجو ان يفي بطلبك وفي انتظار ردك جزاك الله خيرا سجلات الحساب1.rar

طريقة عمل شاشة ( فورم ) ادخال وترحيل واستعلام وتعديل !! خطوة خطوة السلام عليكم اساتذة المنتدي وخبراؤه الكبار الاخوة الافاضل بالطبع هناك اكواد كثيرة لعمل شاشة الادخال وكذلك الاستعلام والتعديل والحذف ولكني قصدت اختيار اسهل هذه الاكواد لعمل ذلك لتكون اسهل في توصيل المعلومة وكذلك اسهل عند التطبيق وارجو من الله ان اكون قد وفقت في عمل ذلك (((( الدرس الخامس )))) شاشة ( فورم ) لادخال بيانات والقيام بتسجيل وترحيل هذه البيانات الي صفحة الاكسيل و الاستعلام من خلالها عن طريق نفس الفورم والتعديل ايضا في البيانات في حالة ما اردنا التعديل في بيان قد سبق ادخاله وطبعاً والاكيد كله من علمكم اساتذتي الكرام الاجلاء في هذا الدرس سنتعرف علي طريقة عمل زر للحذف بعد عمل استعلام عن الاسم او الرقم المطلوب وذلك في نفس الفورم الذي قمنا بتصميمه وذلك للبيانات السابق تسجيلها في صفحة البيانات وذلك عن طريق استخدام زر الحذف ... مع وضع اكواده ... وشرح الكود سطر سطر كما تعودنا واي استفسار .... في الخدمة دائما ... واي شئ غير واضح في الشرح علي استعداد تام لشرحه مرة اخري ومرات اخري واليكم ايضا في المرفقات : 1- ملف اكسيل به الاكواد والشرح هذه المرة داخل الكود ( تم شرح الكود سطر سطر بطريقة وافية وبسيطة جدا داخل الكود نفسه ) 2- عدد ( 1 ) ملف فيديو يشرح طريقة التصميم واضافة الاكواد وكذلك مشاهدة النتيجة واضافة بسيطة لكفاءة عمل زر تسجيل جديد جزاكم الله خيرا اساتذتنا اكسيل ..طريقة عمل شاشة ادخال واستعلام وتعديل وحذف5.rar طريقة عمل زر الحذف فيديو.rar ارجو من الله ان اكون قد وفقت فيما تم تقديمه من شرح وان يكون كل شئ واااضح وبطريقة اعجبتكم وانا علي استعداد تام لشرح اي جزء مرة اخري

السلام عليكم اخي العزيز / عمرو_ بارك الله فيك اخي الكريم علي مشاركتك الرائعة والمفيده حقا وبالنسبة لكلمتك ( وارجو ان اكون ما فهمته صحيح ) فبالفعل بعد مشاهدة ردك هذا اتضح لي انني انا الذي لم افهم المقصود كما ينبغي وقد اتضح لي لآن جزاك الله كل الخير اخي الكريم

Sub To_yawmiyah_aamah() Dim FS As Worksheet, TS As Worksheet Dim R, TR Set FS = Sheets(ActiveSheet.Name) Set TS = Sheets("اليومية العامة") TR = TS.Range("Z4") For R = 9 To 25 If FS.Range("AA" & R) = False Then GoTo 9 FS.Range("AB" & R & ":AL" & R).Copy TR = TR + 1 TS.Range("E" & TR).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 9 Next R Application.CutCopyMode = False FS.Range("I9:L25").ClearContents MsgBox "تم حفظ اليومية بنجاح ---", , "الحمد لله" End Sub

السلام عليكم اخى الكريم حماده عمر وفقك الله وجزاك خيرا على هذا المجهود الجبار واسمح لى بتعليق بسيط على موضوع ترتيب العمل بالانتقال بالانتر الي الاسفل فالاسفل في نفس العمود ويعلم الله لكى تعم الفائدة ولاثراء موضعك المتميز فان كان ما فهمته صحيح.. يمكنك عمل ذلك بدون تغيير تصميم التكست بوكس او حتى اعادة ترتيبها يتم ذلك عن طريق خصائص التكست بوكس و ذلك عن طريق تغيير رقم ال Tabindex داخل خصائص التكست بوكس فبعد انتهائنا من وضع الكائنات داخل ال Userform يمكنك عمل ترتيب الانتقال بانتر عن طريق اعطاء ارقام متتاليه لل Tabindex لكل كائن على حده فمثلا التكست بوكس 1 اذا كانت ال Tabindex =1 واردنا الانتقال الى تكست بوكس 6 بعد الضغط على انتر نذهب الى خصائص التكست بوكس 6 ونضع Tabindex=2 وهكذا تستطيع عمل الترتيب الذى تريده ولايشترط ترتيب فى التصميم شاهد الملف المرفق لاخونا احمد مجدى بعد التعديل ( انتقال بانتر فى ايصال صرف النقديه وايصال استلام النقديه) وارجو ان اكون ما فهمته صحيح جزاك الله خيرا اخى حماده عمر الايصالات 8+.rar

السلام عليكم الاخ الكريم / جلال محمد تفضل اخي الكريم جرب المرفق .. عله يكون المطلوب اعمال السنة11.rar

بارك الله فيك اخي ابو محمد === تم اغلاق الموضوع لانه تمت اجابته كما تم فصل السوال الثاني في مشاركة منفصلة للفائدة

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

السلام عليكم ورحمة الله وبركاته أولا : أخي قم بضبط إعدادات اللغة من الويندوز لوحة التحكم ثم قم بضبطها إن لم تفلح جرب الطريقة الثانية جرب هذه الطريقة في محرر الاكواد من قائمة Tools ثم Option من تاب Editor Format ثم Font اختر نوع الخط هذا Courier New (Arabic)

طريقة عمل شاشة ( فورم ) ادخال وترحيل واستعلام وتعديل !! خطوة خطوة السلام عليكم اساتذة المنتدي وخبراؤه الكبار الاخوة الافاضل اقدم لكم في هذه المشاركة شرح ( للامانه ) فهو منقول من منتدي آخر وشرح لاحد الأخوة ولكن لا اتذكر الاسم الآن والجميل به وما جعلني اقوم بوضعه هنا في هذا الموضوع ان به شرح الماكرو كامل وكذلك شرح لمعظم ما قمنا باستخدامه في الاكواد في الدروس السابقة من التعامل مع الخلايا في الاكسيل ودالة IF و .... اترككم مع الملفات في الدرس القادم والاخير سنتعرف علي طريقة عمل زر (( للحذف )) ووضع الاكواد الخاصة به مع شرحه سطر سطر كما تعودنا مع المرفقات الخاصه به .... وايضا كما تعودنا باسهل اكواد ممكنة لعمل تلك الوظائف واي استفسار .... في الخدمة دائما ... واي شئ غير واضح في الشرح علي استعداد تام لشرحه مرة اخري ومرات اخري جزاكم الله خيرا شرح الماكرو.rar 2- دروس في التعامل مع الخلايا في الاكسيل.rar

السلام عليكم الاخ الكريم / احمد مجدى تفضل المرفق به طلب فئه العميل في شاشة تسجيل عميل جديد جزاك الله خيرا الايصالات 7+.rar

السلام عليكم اليك الملف المرفق والخاص بترقيم الاذون كل اذن بترقيم منفردا وترقيم خاص به ولكن يتم ذلك باستخدام شيت 3 فلا يمكن حذفه اوتغير اسمه وجاري النظر في ملاحظاتك الاخيرة جزاك الله خيرا الايصالات 7.rar

السلام عليكم الاخ الكريم / احمد مجدى اليك اخي الملف المرفق به انهاء معظم ملاحظاتك 1- فورم البحث تم تشغيله بشكل رااائع 2- ايصال استلام نقدية ( تم فتح خانة المتبقي كما تريد ) .... ( وهل تم الوصول الى صافى المديونية للعميل اى انه عند دفع باقى المبلغ يكون المتبقى = صفر ) .... سأقوم باضافة ذلك اليوم ( ان شاء الله ) 3- بالنسبة ايصال صرف نقدية / شيكات تم تعديل الترحيل و تم تنفيذ رصيد الخزينة كما تريد ولكن ولكن بالنسبة لرقم الأذن احتاج لاستفسار هل كل ارقام الاذون الموجودة لديك تكمي بعضها اي متسلسلة وراء بعضها ام ان كل نوع له مسلسل يخصه هو فقط ... حيث لم نتطرق لهذه النقطة قبل ذلك 4- تم حل مشكلة اغلاق الشاة الرئيسية 5-تم عمل زر اسمه ترحيل وطباعة مع ترك الزرين طباعة - ترحيل ايضا 6- بالنسبة للنقطة الخاصة بعدم الكتابة في القائمة التي تقوم بالاختيار منها ( ان شاء الله اليوم ) جزاك الله خيرا الايصالات 6++ (version 2).rar