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

قبل شهور كنت قد كتبت هدا الكود الدي يعطي للمستخدم امكانية التحكم في لون ال UserForm Title Bar و التحكم في حجم و لون و شكل ال Font أي الخط المكتوب به ال UserForm Caption كل حرف على حدى الكود لا يشتغل في اجهزة ال 64Bit Windows ملف للتحميل : https://app.box.com/s/l96isv4jal2rns144zy5 1- كود في Standard Module : 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 LOGBRUSH lbStyle As Long lbColor As Long lbHatch As Long End Type Private Type PAINTSTRUCT hdc As Long fErase As Long rcPaint As RECT fRestore As Long fIncUpdate As Long rgbReserved(32) As Byte End Type Private Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName As String * 32 End Type Private Type FontAttributes FONT_NAME As String FONT_SIZE As Long FONT_BOLD As Boolean FONT_ITALIC As Boolean FONT_UNDERLINE As Boolean End Type Private Type TRIVERTEX x As Long y As Long Red As Integer Green As Integer Blue As Integer Alpha As Integer End Type Private Type GRADIENT_RECT UpperLeft As Long LowerRight As Long End Type Private Declare Function CreateFontIndirect Lib "gdi32" _ Alias "CreateFontIndirectA" _ (lpLogFont As LOGFONT) As Long Private Declare Function GetWindowDC Lib "user32" _ (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" _ (ByVal hwnd As Long, _ ByVal hdc As Long) As Long Private Declare Function TextOut Lib "gdi32" _ Alias "TextOutA" _ (ByVal hdc As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal lpString As String, _ ByVal nCount As Long) As Long Private Declare Function SetBkMode Lib "gdi32" _ (ByVal hdc As Long, _ ByVal nBkMode As Long) As Long Private Declare Function SelectObject Lib "gdi32" _ (ByVal hdc As Long, _ ByVal hObject As Long) As Long Private Declare Function SetWindowsHookEx Lib _ "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, _ ByVal lpfn As Long, _ ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" _ (ByVal hHook As Long) As Long Private Declare Function CallNextHookEx Lib "user32" _ (ByVal hHook As Long, _ ByVal ncode As Long, _ ByVal wParam As Long, _ lParam As Any) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" _ () As Long Private Declare Function SetWindowLong Lib "user32" _ Alias "SetWindowLongA" _ (ByVal hwnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Declare Function CallWindowProc Lib "user32" _ Alias "CallWindowProcA" _ (ByVal lpPrevWndFunc As Long, _ ByVal hwnd As Long, _ ByVal Msg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Private Declare Function GetClassName Lib "user32" _ Alias "GetClassNameA" _ (ByVal hwnd As Long, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long) As Long Private Declare Function DeleteObject Lib "gdi32" _ (ByVal hObject As Long) As Long Private Declare Function SetTextColor Lib "gdi32" _ (ByVal hdc As Long, _ ByVal crColor As Long) As Long Private Declare Function CreateBrushIndirect Lib "gdi32" _ (lpLogBrush As LOGBRUSH) As Long Private Declare Function FillRect Lib "User32.dll" _ (ByVal hdc As Long, _ ByRef lpRect As RECT, _ ByVal hBrush As Long) As Long Private Declare Function SetRect Lib "user32" _ (lpRect As RECT, _ ByVal X1 As Long, _ ByVal Y1 As Long, _ ByVal X2 As Long, _ ByVal Y2 As Long) As Long Private Declare Function GetWindowRect Lib "User32.dll" _ (ByVal hwnd As Long, _ ByRef lpRect As RECT) As Long Private Declare Function BeginPaint Lib "User32.dll" _ (ByVal hwnd As Long, _ ByRef lpPaint As PAINTSTRUCT) As Long Private Declare Function EndPaint Lib "User32.dll" _ (ByVal hwnd As Long, _ ByRef lpPaint As PAINTSTRUCT) As Long Private Declare Function InvalidateRect Lib "User32.dll" _ (ByVal hwnd As Long, _ ByVal lpRect As Long, _ ByVal bErase As Long) As Long Private Declare Function GetSystemMetrics Lib "user32" _ (ByVal nIndex As Long) As Long Private Declare Function SetMapMode Lib "gdi32" _ (ByVal hdc As Long, _ ByVal nMapMode As Long) As Long Private Declare Function DrawText Lib "user32" Alias "DrawTextA" _ (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, _ lpRect As RECT, ByVal wFormat As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias _ "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long) Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" _ (dst As Any, ByVal iLen As Long) Private Declare Function GetTextColor Lib "gdi32" ( _ ByVal hdc As Long) As Long Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As _ Long, ByVal y As Long) As Long Private Declare Function IsBadWritePtr Lib "kernel32" _ (ByVal lp As Long, ByVal ucb As Long) As Long Private Declare Function GradientFillRect Lib "msimg32" Alias "GradientFill" _ (ByVal hdc As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, _ pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long Private Declare Function PtInRect Lib "user32" _ (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long Private Declare Function ScreenToClient Lib "User32.dll" _ (ByVal hwnd As Long, _ ByRef lpPoint As POINTAPI) As Long Private Declare Function DrawFrameControl Lib "user32" _ (ByVal hdc As Long, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Long Private Declare Function OffsetRect Lib "user32" _ (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long Private Const DFC_CAPTION = 1 Private Const DFCS_CAPTIONCLOSE = &H0 Private Const DT_CALCRECT = &H400 Private Const WH_CBT As Long = 5 Private Const HCBT_ACTIVATE As Long = 5 Private Const GWL_WNDPROC As Long = -4 Private Const WM_ACTIVATE As Long = &H6 Private Const WM_PAINT As Long = &HF& Private Const WM_SHOWWINDOW As Long = &H18 Private Const WM_EXITSIZEMOVE As Long = &H232 Private Const WM_DESTROY As Long = &H2 Private Const SM_CYCAPTION As Long = 4 Private Const COLOR_ACTIVECAPTION = 2 Private Const GRADIENT_FILL_RECT_H As Long = &H0 Private Const WM_SYSCOMMAND = &H112 Private Const SM_CXSIZE = 30 Private Const SM_CYSIZE = 31 Private Const WS_SYSMENU = &H80000 Private Const GWL_STYLE As Long = (-16) Private tFontAttr As FontAttributes Private tr2 As RECT Private tRect As RECT Private lPrevWnd As Long Private lhHook As Long Private bHookEnabled As Boolean Private oForm As Object Private bGradientFill As Boolean Private lCharColorsPtr As Long Private bCreateFont As Boolean Private lDefaultFontColor As Long Private sFontName As String Private lFontSize As Long Private bFontBold As Boolean Private bFontItalic As Boolean Public bFontUnderline As Boolean Private sCaptionText As String Private lTitleBarColor As Long Private lFontColour As Long Private aCharColors() As Variant Public Sub ShowFormatedUserForm( _ ByVal Form As Object, _ Optional ByVal TitleBarColor As Long, _ Optional ByVal GradientFill As Boolean, _ Optional ByVal FontAttributesPtr As Long, _ Optional CharColorsPtr As Long _ ) Call HookUserForm(ByVal Form, _ ByVal TitleBarColor, _ ByVal GradientFill, _ ByVal FontAttributesPtr, _ CharColorsPtr _ ) End Sub Private Sub HookUserForm _ (ByVal Form As Object, ByVal TitleBarColour As Long, _ ByVal GradientFill As Boolean, ByVal FontAttributesPtr As Long, _ CharColorsPtr As Long) If Not bHookEnabled Then Set oForm = Form sCaptionText = Form.Caption Form.Caption = vbNullString lCharColorsPtr = CharColorsPtr bGradientFill = GradientFill lTitleBarColor = IIf(TitleBarColour = 0, _ GetSysColor(COLOR_ACTIVECAPTION), TitleBarColour) lDefaultFontColor = IIf(CharColorsPtr = 0, GetSysColor(9), 0) If IsBadWritePtr(FontAttributesPtr, 4) = 0 Then If FontAttributesPtr <> 0 Then CopyMemory ByVal tFontAttr, ByVal FontAttributesPtr, LenB(tFontAttr) With tFontAttr sFontName = .FONT_NAME lFontSize = .FONT_SIZE bFontBold = .FONT_BOLD bFontItalic = .FONT_ITALIC bFontUnderline = .FONT_UNDERLINE End With bCreateFont = True Else bCreateFont = False End If End If If IsBadWritePtr(CharColorsPtr, 4) = 0 Then If CharColorsPtr <> 0 Then ReDim aCharColors(Len(sCaptionText)) CopyMemory aCharColors(0), ByVal CharColorsPtr, 16 * (UBound(aCharColors) + 1) ZeroMemory ByVal CharColorsPtr, 16 * (UBound(aCharColors) + 1) Else Erase aCharColors() End If End If lhHook = SetWindowsHookEx _ (WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId) bHookEnabled = True Form.Show Else MsgBox "The hook is already set.", vbInformation End If End Sub Private Function HookProc _ (ByVal idHook As Long, ByVal wParam As Long, _ ByVal lParam As Long) As Long Dim sBuffer As String Dim lRetVal As Long Dim lDc As Long If idHook = HCBT_ACTIVATE Then sBuffer = Space(256) lRetVal = GetClassName(wParam, sBuffer, 256) If Left(sBuffer, lRetVal) = "ThunderDFrame" Or _ Left(sBuffer, lRetVal) = "ThunderXFrame" Then lDc = GetWindowDC(wParam) ReleaseDC wParam, lDc lPrevWnd = SetWindowLong _ (wParam, GWL_WNDPROC, AddressOf CallBackProc) UnhookWindowsHookEx lhHook bHookEnabled = False End If End If HookProc = CallNextHookEx _ (lhHook, idHook, ByVal wParam, ByVal lParam) End Function Private Function CallBackProc _ (ByVal hwnd As Long, ByVal Msg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Static i As Long Dim lDc As Long Dim lStyle As Long Dim loword As Long Dim hiword As Long Dim tPt As POINTAPI Dim x As Long Dim pt As POINTAPI Dim tr As RECT On Error Resume Next GetWindowRect hwnd, tRect Select Case Msg Case WM_PAINT, WM_ACTIVATE If Msg = WM_ACTIVATE Then lStyle = GetWindowLong(hwnd, GWL_STYLE) SetWindowLong hwnd, GWL_STYLE, (lStyle And Not WS_SYSMENU) End If lDc = GetWindowDC(hwnd) Call DrawTitleBar(hwnd, lTitleBarColor) SetBkMode lDc, 1 If bCreateFont Then CreateFont lDc End If For i = 1 To Len(sCaptionText) If lCharColorsPtr = 0 Then SetTextColor lDc, lDefaultFontColor Else SetTextColor lDc, aCharColors(i - 1) End If SetRect tr, 0, 0, 0, 0 DrawText lDc, Mid(sCaptionText, i, 1), _ Len(Mid(sCaptionText, i, 1)), tr, DT_CALCRECT If x = 0 Then x = 4 TextOut lDc, x, GetSystemMetrics(SM_CYCAPTION) / 3, _ Mid(sCaptionText, i, 1), Len(Mid(sCaptionText, i, 1)) x = x + Abs(tr.Right - tr.Left) Next lFontColour = GetTextColor(lDc) ReleaseDC hwnd, lDc InvalidateRect hwnd, 0, 0 Case WM_EXITSIZEMOVE, WM_SHOWWINDOW Call DrawTitleBar(hwnd, lTitleBarColor) InvalidateRect hwnd, 0, 0 Case WM_SYSCOMMAND GetHiLoword lParam, loword, hiword tPt.x = loword tPt.y = hiword ScreenToClient hwnd, tPt If PtInRect(tr2, tPt.x, -tPt.y) Then Unload oForm End If Case WM_DESTROY SetWindowLong hwnd, GWL_WNDPROC, lPrevWnd bGradientFill = False lCharColorsPtr = 0 bCreateFont = False lDefaultFontColor = 0 sFontName = vbNullString lFontSize = 0 bFontBold = False bFontItalic = False bFontUnderline = False sCaptionText = vbNullString lTitleBarColor = 0 lFontColour = 0 Erase aCharColors() Set oForm = Nothing End Select CallBackProc = CallWindowProc _ (lPrevWnd, hwnd, Msg, wParam, ByVal lParam) End Function Private Sub CreateFont(DC As Long) Dim uFont As LOGFONT Dim lNewFont As Long With uFont .lfFaceName = sFontName & Chr$(0) .lfWidth = lFontSize .lfWeight = IIf(bFontBold, 900, 100) .lfItalic = bFontItalic .lfUnderline = bFontUnderline End With lNewFont = CreateFontIndirect(uFont) DeleteObject (SelectObject(DC, lNewFont)) End Sub Private Sub ConvertLongToRGB(ByVal Value As Long, r As Byte, g As Byte, b As Byte) r = Value Mod 256 g = Int(Value / 256) Mod 256 b = Int(Value / 256 / 256) Mod 256 End Sub Private Function LongToUShort(Unsigned As Long) As Double LongToUShort = CInt(Unsigned - &H10000) End Function Private Function TransfCol(ByVal Col As Long) As Double Dim a As Double If Col = 0 Then TransfCol = 0 ElseIf Col > 127 Then a = 256 - Col TransfCol = -(256 * a) Else a = Col TransfCol = 256 * a End If End Function Private Sub DrawTitleBar _ (lhwnd As Long, ByVal MyColor As Long) Dim tPS As PAINTSTRUCT Dim tLB As LOGBRUSH Dim tr As RECT Dim lDc As Long Dim l As Long Dim hBrush As Long Dim vert(2) As TRIVERTEX Dim tPt As GRADIENT_RECT Dim r As Byte, g As Byte, b As Byte Call BeginPaint(lhwnd, tPS) lDc = GetWindowDC(lhwnd) tLB.lbColor = MyColor hBrush = CreateBrushIndirect(tLB) Call GetWindowRect(lhwnd, tr) SetRect tr, 0, 0, tr.Right, tr.Bottom SetRect tr2, 0, 5, _ GetSystemMetrics(SM_CXSIZE), GetSystemMetrics(SM_CYSIZE) + tr.Bottom OffsetRect tr2, tRect.Right - tRect.Left - GetSystemMetrics(SM_CXSIZE), 0 FillRect lDc, tr, hBrush If bGradientFill Then ConvertLongToRGB MyColor, r, g, b With vert(0) .x = 0 .y = 0 .Red = TransfCol(r) .Green = TransfCol(g) .Blue = TransfCol(b) .Alpha = TransfCol(0) End With With vert(1) .x = tr2.Right .y = tr2.Bottom .Red = TransfCol(0) .Green = TransfCol(0) .Blue = TransfCol(0) .Alpha = TransfCol(0) End With tPt.UpperLeft = 0 tPt.LowerRight = 1 GradientFillRect lDc, vert(0), 2, tPt, 1, GRADIENT_FILL_RECT_H End If Call DeleteObject(hBrush) SetRect tr2, tr2.Right - GetSystemMetrics(SM_CXSIZE), 0, _ tr2.Right, GetSystemMetrics(SM_CYSIZE) OffsetRect tr2, -4, 2 DrawFrameControl lDc, tr2, DFC_CAPTION, DFCS_CAPTIONCLOSE ReleaseDC lhwnd, lDc Call EndPaint(lhwnd, tPS) End Sub Private Sub GetHiLoword _ (lParam As Long, ByRef loword As Long, ByRef hiword As Long) loword = lParam And &HFFFF& hiword = lParam \ &H10000 And &HFFFF& End Sub 2- كود في Standard Module اخر : Option Explicit Private Type FontAttributes FONT_NAME As String FONT_SIZE As Long FONT_BOLD As Boolean FONT_ITALIC As Boolean FONT_UNDERLINE As Boolean End Type Sub test() Dim tFontAttr As FontAttributes Dim aCharColors() As Variant Dim lTitleBarColor As Long 'define a random title bar color lTitleBarColor = RGB(0, 255, 0) 'build the caption font structure With tFontAttr .FONT_NAME = "Arial" '"Trebuchet MS" .FONT_SIZE = 8 .FONT_BOLD = True .FONT_ITALIC = False .FONT_UNDERLINE = False End With 'build the caption individual character colors ReDim aCharColors(Len(UserForm1.Caption)) '===> (=16 chars in this case) aCharColors(0) = vbRed 'U aCharColors(1) = vbRed 's aCharColors(2) = vbRed 'e aCharColors(3) = vbRed 'r aCharColors(4) = vbBlue 'F aCharColors(5) = vbBlue 'o aCharColors(6) = vbBlue 'r aCharColors(7) = vbBlue 'm aCharColors(8) = vbYellow '1 aCharColors(9) = 0 aCharColors(10) = vbRed '- aCharColors(11) = 0 aCharColors(10) = vbWhite 'D aCharColors(12) = vbWhite 'e aCharColors(13) = vbWhite 'm aCharColors(14) = vbWhite '0 aCharColors(15) = vbWhite '0 'display the userform Call ShowFormatedUserForm( _ Form:=UserForm1, _ TitleBarColor:=lTitleBarColor, _ GradientFill:=True, _ FontAttributesPtr:=VarPtr(tFontAttr), _ CharColorsPtr:=VarPtr(aCharColors(0)) _ ) End Sub

كود لجعل الفورم شفاف مع الابقاء على شريط عنوان الفورم و اطاره و على جميع الكونترولات بداخله ملف للتحميل : https://app.box.com/s/pzaml5g8slh8kq7bd03axq01vzmrldai الكود في موديول الفورم: Option Explicit Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long Private Const LWA_COLORKEY = &H1 Private Const GWL_EXSTYLE = (-20) ' Private Const WS_EX_LAYERED = &H80000 Private Sub UserForm_Initialize() Dim hwnd As Long hwnd = FindWindow(vbNullString, Me.Caption) SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED Me.BackColor = vbRed SetLayeredWindowAttributes hwnd, vbRed, 0&, LWA_COLORKEY End Sub

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

50 مشاركة ... 67 إعجاب .. يعني إعجاباتك تجاوزت عدد مشاركاتك وهذ متوقع من أعمالك التي حرمنا منها طويلاً الحمد لله أن رزقنا الله بك أخي الحبيب جعفر تقبل تحياتي

شكرا يا أستاد محمد حسن الكود يشتغل جيدا على أجهزة 32Bit .. و لكي يشتغل على 64Bit يتطلب تعديلا على ال API declarations تعديل ال Windows API declarations ليس أمرا صعبا لكنه يتطلب امتلاك جهاز من 64Bit لتجريب الكود ... للأسف ليس لدي جهاز 64Bit لكي أعدل و أجرب الكود .. ان شاء الله قريبا سأبدل الجهاز

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

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

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

استاذى وابى الفاضل واسمح لى ان اكون مثل ابنك والله انك لمبدع كل ما اود قوله ان يزيدك الله من فضله وكرمه (والله هذا الدعاء نطق به لسانى دون تفكير مجرد رأيتى للعمل) تقبل تحياتى

ليس ضروريا أن يتم الاشارة الى الفرييم داخل الكود ... لو السطر التالي لا ينتج عنه خطأ ابتداء من الدورة الثانية في ال Do .. Loop : Set oRealActiveControl = oTempObj.ActiveControl يعني أننا بصدد Frame Control

السلام عليكم و رحمة الله و بركاته بارك الله فيك على هذه الاضافة .. جزاك الله خيرًا و زادها بميزان حسناتك تحياتي

في حالة وضع التيكست بوبكس داخل فريم يمكن استعمال الكود التالي : ملف للتحميل : https://app.box.com/s/5ttc2dafv4sj3e1g03r95ppd57ftqqmg Private Sub Label1_Click() Dim oTempObj As Object Dim oRealActiveControl As Object On Error Resume Next Set oTempObj = Me Do Set oRealActiveControl = oTempObj.ActiveControl If Err <> 0 Then Exit Do Set oTempObj = oRealActiveControl DoEvents Loop On Error GoTo 0 If TypeName(oRealActiveControl) = "TextBox" Then If Len(oRealActiveControl) = 0 Then oRealActiveControl = Date Else MsgBox "Date already entered in TextBox : '" & oRealActiveControl.Name & "'" End If Else MsgBox "You need to select a TextBox first" End If End Sub

بارك الله فيك أيها المتمكن خالد صراحة يعجبني أسلوبك في المعادلات بشكل رهيب وخصوصاً الدالة INDIRECT ..كأنها سحر المعادلات

استاذى الحبيب ياسر اسمح لى ان اقدم مشاركة لاثراء الموضوع ... بإستخدام المعادلات اخى الكريم الملف المرفق قائم على فكرة اضافة قيمة الدفعة ليظهر اجمالى الدفعات المسددة والمبلغ المتبقى تلقائى ايرادات KG.rar

برنامج_مخازن_جديد.xlsm

بسم الله الرحمن الرحيم سنبدا ان شاء الله فى تناول كتيب قمت باعداده عن ادوات التحليل ماذا لو واطلب من الجميع تاجيل التعليقات والاستفسارات حتى انتهى من النشر وساقوم بالتنويه حال الانتهاء من النشر . تقبلوا تحياتى . ===================================================================== استخدام أدوات التحليل ماذا-لو؟ الموجودة في الاكسيل Microsoft Office Excel what-if analysis ===================================================================== مقدمة: من أكثر الأدوات الرائعة والمتميزة الموجودة في الاكسيل هي أدوات التحليل ماذا –لو (what-if analysis) حيث تقوم بعرض نتائج بشكل ديناميكي أيضا تقوم بتغيير القيم في الخلايا لمعرفة كيفية تأثير هذه التغييرات على ناتج الصيغ في ورقة العمل. وتحليل ماذا لو يجيب على تساؤلات كثيرة :لنفترض أنك ستقوم بشراء سيارة او منزل او نقوم بعمل تحليل مالي فماذا-لو تغير معدل الفائدة من 7.5% الى 7%؟ فماذا-لو رفعنا أسعار المنتجات الى 5% من السعر الحالي؟ فماذا-لو ارتفعت أجور العاملين الى 10% من العام الماضي؟ .............................. الخ العديد من التساؤلات نحتاج ان نضع نتائج سريعة لها حتى نستطيع اتخاذ القرار المناسب يمكن الإجابة على مثل هذه التساؤلات عن طريق أدوات التحليل ماذا لو what-if analysis الموجودة في ميكروسوفت اكسيل Microsoft Office Excel وهي كالاتي: إدارة السيناريو (Scenario Manager) الاستهداف (Goal Seek) جداول البيانات (data tables) الأدوات الإضافية add-in مثل solve وأدوات أخرى. ملاحظة: يمكنك عمل تحليل ماذا-لو؟ بشكل يدوي manual what-if analysis عن طريق ادخال قيم يدوية وعمل خلايا صيغ تقوم بعرض النتائج بناء على القيم التي ادخلتها. ثم مشاهدة مثل هذه التغيرات. الوصول لهذه الأدوات كما في الشكل التالي: انتقل الى علامة تبويب بيانات DATE اختار أدوات التحليل ماذا لو ======================================================= اولا: استخدام جداول البيانات Creating data tables ======================================================= جداول البيانات هي واحده من أكثر الميزات الغير مستغله في الاكسيل وهي عباره عن نطاق ديناميكي يلخص الصيغ والمعادلات في خلايا المدخلات. حيث يعرض نتائج أكثر من احتمال او تصور في مكان واحد وبشكل سريع ولكن جداول البيانات لها بعض القيود حيث تتعامل مع مدخل واحد او اثنين فقط في نفس الوقت . ======================================================= النوع الأول: انشاء جدول بيانات من متغير واحد (ادخال واحد فقط) ======================================================= جدول البيانات ذات المتغير الواحد او الادخال الواحد يعرض نتائج صيغه واحده او اكثر من صيغه لقيم مختلفة في خلية ادخال واحده . ويمكن عمل هذا الجدول في اى مكان في ورقة العمل العمود الايمن: يحتوي على قيم الادخال اليدوية الصف العلوى: يشير الى صيغه او مرجع خليه الخلية العلوية اعلى العمود الايسر تترك فارغه. ======================================================= خطوات عمل هذا النوع من جدول البيانات ذات المتغير الواحد او الادخال الواحد . ======================================================= اذا كان الادخال اليدوى في خلية ادخال العمود اكتب الصيغة في ادخال خلية ادخال الصف والعكس اذا كان الادخال اليدوي في خلية ادخال الصف اكتب الصيغة في خلية ادخال العمود حدد الخلايا او النطاق التي تحتوي على الصيغة والادخال اليدوي التي تريد عرض نتائج او تصورات عنها وليكن معدل الفائدة. افتح جدول البيانات من TAB بيانات DATE . حدد مرجع خلية الادخال اليدوي . اذا كان قيم الادخال اليدوى في موقع خلية ادخال العمود اكتب مرجع ادخال العمود في مربع الحوار . والعكس إذا كان قيم الادخال اليدوي في موقع ادخال الصف اكتب مرجع ادخال الصف سنتعرض لذلك لاحقا في الأمثلة والحالات العملية. اضغط موافق المشاركة التالية الامثلة العملية 1-0.rar

صحيح هناك فرق في الاصدار http://ge.tt/3mKjbCO2/v/0 ملف college اقدم من ramz الحل هو اما ان تقوم بتحويل ملف ramz وقد قمت بذلك نيابة عنك او ان تقوم بعملية الاستيراد بالعكس اي تستورد ملف college من ملف ramz

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

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

السلام عليكم ورحمة الله وبركاته اخي الحبيب محمد حسن المحمد زادك الله من فضله ووفقك لما يحبه ويرضاه دائما سباق الى الخير

اخي حسين كودك الذي عرضته بالمشاركة الاولى يحقق طلبك If Dir("C:\WINDOWS\MOVI.txt") = "" Then MsgBox "يعمل" Else MsgBox "لا تعمل" End If ايضا الكود الثاني والذي عرضه الاستاذ محمد If Len(Dir("C:\WINDOWS\MOVI.txt")) > 0 Then MsgBox "لا يعمل" Else MsgBox "اعمل" End If

شكرا اخي الفاضل ابو خليل علي مرورك الطيب لوسمحت اخي الفاضل ابو خليل التعديل علي الكود ليتناسب مع اذا كان الملف غير موجود إذا فيكون الجواب الاول = تشغيل ، وإلا = اغلاق

إن لله وإن إلية راجعون اللهم ارحمه رحمة واسعه اللهم اسكينه فسيح جناتك ------------------------------------- كان من مقولاته ( الجميع يفكر في تغيير العالم, ولكن لا أحد يفكر في تغيير نفسه ) كان من مواليد 1977 ----------------------------------------------------- اللهم ان كان ينعم فى قبرة فزيد فى نعيمه وانزل عليه الفرح والسرور والحور وان كان يعذب فاللهم ارفع عنه العذاب يا رب العالمين

يتكرر بسب عدم وجود مفتاح اساسي منفرد ويبدو ان لديك تكرار حقيقي في رقم الفاتورة انظر التعديل الآن : يستحيل التكرار سيتم عرض سجل واحد فقط بمعلومية حقلي رقم الفاتورة والشراء يوجد عندي مشكلة في رفع الملفات الحل هو ان تجعل حقل الشراء معيار ايضا مع رقم الفاتورة في التقرير ليصبح داخل التقرير معيارين

السلام عليكم الاخ الصقر المحترم شكرا على البرنامج لانة عمل رائع ولي طلب هور ان امكن شرح البرنامج بشكل متسلسل في الادخال

أظن المشكلة في الحجم الكبير للفورم ... عدد الكونترولات في الفورم كبير جدا بحيث لم يعد هنالك ال memory الكافية لاشتغال الفورم بما أن كل الصفحات متشابهة من حيث الشكل و من حيث عدد الليبيلس و التيكستبوكس من الأفضل استعمال ال TabStrip Control عوض ال MultiPage Control طبعا لو استعملت ال TabStrip Control ستحتاج الى مزيد من الكود ... حاول تبحث في الانتيرنيت حول كيف يشتغل ال TabStrip Control

يا غالى دخلت على الرابط لا يفتح حاول ارفعه على سرفر المنتدى تقبل تحياتى

نسأله تعالى أن يغفر له ويرحمه ويدخله الجنة

وجزاك ربي خيرا اخونا عزيز اقصد بالنسخة واللاحقة هي اسم قاعد الجداول ولاحقتها : Data.mdb والموجودة بهذه العبارة Shell "cmd.exe /C copy " & """" & DBOld & """" & " " & """" & DBNew & "\" & "Data.mdb" & """", 0

السلام عليكم ورحمة الله أخي الكريم أبو مريم، المرفق الذي وضعته به خلل ولا يمكن تحميله... وأقترح عليك المعادلة التالية إذا فرضنا أن نطاق القيم هو A1:A1000 : =SMALL(A1:A1000;COUNTIF(A1:A1000;0)+1) مع مراعاة "الفاصلة المنقوطة" و"الفاصلة" وتغيير النطاق إذا استدعى الأمر ذلك... بن علية

السلام عليكم و رحمة الله و بركاته جزاك الله خيرًا أستاذنا الفاضل .. و الله تحفة حقيقية .. واصل تألّقك و إبداعاتك بارك الله فيك .. وفّقك الله و سدّد خطاك لما يحبّه و يرضاه خالص احتراماتي

اللهم صل و سلم على محمد و على آل محمد كما صليت على إبراهيم و على آل إبراهيم و بارك على محمد و على آل محمد كما باركت على إبراهيم و على آل إبراهيم في العالمين إنك حميد مجيد ....اللَّهُمَّ اغْفِرْ لَهُ وَارْحَمْهُ وَعَافِهِ وَاعْفُ عَنْهُ وَأَكْرِمْ نُزُلَهُ وَوَسِّعْ مُدْخَلَهُ وَاغْسِلْهُ بِالْمَاءِ وَالثَّلْجِ وَالْبَرَدِ وَنَقِّهِ مِنْ الْخَطَايَا كَمَا نَقَّيْتَ الثَّوْبَ الْأَبْيَضَ مِنْ الدَّنَسِ وَأَبْدِلْهُ دَارًا خَيْرًا مِنْ دَارِهِ وَأَهْلًا خَيْرًا مِنْ أَهْلِهِ وَزَوْجًا خَيْرًا مِنْ زَوْجِهِ وَأَدْخِلْهُ الْجَنَّةَ وَأَعِذْهُ مِنْ عَذَابِ الْقَبْرِ وَ مِنْ عَذَابِ النَّارِ....... اللهم اجعل كل ما قدمه من أعمال و مساعدات في ميزان حسناته .... لا يسعني إلا أن أعزيكم إخواني .... أعظم الله أجركم و رزقكم الصبر و السلوان إنا لله و إنا إليه راجعون.........

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

بارك الله فيك استاذنا ابو خليل اتفضل اخي محمد هذا المثال من استاذنا الجميل جعفر ضع الفولدر Prog والذي يحتوي علي الجداول المرتبطة علي الD كما هو .. ثم قم بفتح البرنامج الاساسي AA وقم بالخروج سوف ينشيء فولدر تلقائي باسم BAk علي الD وبه نسخة من الجداول المرتبطة بالتاريخ والوقت للاسف يوجد مشكلة بالموقع عند تحميل الملفات اتفضل هذا الكود لحين استطيع تحميل المرفقات On Error GoTo err_Form_Close 'make a backup of BE BE_or_FE = "D:\prog" Backup_Folder = "D:\BAK" 'Do a copy from a PC name wael ONLY 'If VBA.Environ("Computername") <> "wael" Then Exit Sub 'Delete the old saved accdb Kill Backup_Folder & "\AA_BE_*.accdb" 'Now lets work on saving the new accdb''Is this PC name = jj' ' BE_Address = BE_or_FE & "\AA_BE.accdb" BK_Address = Backup_Folder & "\AA_BE_" & Format(Date, "dd-mm-yyyy") & "-" & Format(Now(), "Hh-Nn-AMPM") & ".accdb*" 'Debug.Print "xcopy " & Chr(34) & BE_Address & Chr(34) & " " & Chr(34) & BK_Address & Chr(34) Call Shell("xcopy " & Chr(34) & BE_Address & Chr(34) & " " & Chr(34) & BK_Address & Chr(34), vbHide) Exit Sub err_Form_Close: If Err.Number = 2450 Or Err.Number = 53 Then 'ignor Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If

استاذي يتم الترحيل بالفعل لكن لايتم ترحيل المسلسل ولايتم تحديث ال ComboBox1 بالادخالات الجديدة ليتم التعديل عليها ولك الشكر والاسف علي التقصير فى السؤال الف شكر

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

انا لله وانا اليه راجعون . اللهم تقبل كل اعماله واجعلها صدقة جاريه اسال الله ان يسكنه الفردوس الاعلى

اخى عماد نرحب بك فى منتدانا العظيم ونتمنى ان نرى منك المزيد بارك الله فيك

انا لله و انا اليه لراجعون لاحول ولا قوة الا بالله العلي العظيم اللهم اغفر له و ارحمه واعفو عنه و اكرم نزله

راجع المشاركة ستجدني قلت ضع موشر الماوس في آخر سطر ألا وهو End Sub تقبلوا تحياتي وكل عام وأنتم بخير وأراكم إن شاء الله بعد أجازة العيد في رعاية الله اخى ياسر بالفعل طلع من النوع Variant وبكده ضفت معلومه جديده الى الا وهى ايه ياريت لو كانت صح او غلط ترد عليا علشان اضيف المعلومه الى قاموسى ان فى حالة عدم كتابة نوع المتغير يتم ارجاع الوضع الافتراضى للمتغير وتعريفه على انه من النوع Variant .................................... وياريت يا اخ ياسر لو تضيف الينا شويه معلومات بسيطه عن المتغيرات خصوصا Variant لاننى بصراحه معنديش معلومات كافيه عنها تقبل تحياتى

السلام عليكم انا لله وانااليه راجعون لله ما اعطى ولله ما اخذ كل نفس ذائقة الموت رحم الله فقيدنا الغالي وجعل قبره روض من رياض الجنة

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

رحم الله فقيدنا واسكنه جنات العلى

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

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

إليك أخي الفاضل الملف التالي عله يكون المطلوب تم عمل ورقة تقرير ..اختار الاسم ثم انقر زر الأمر لتظهر البيانات المرتبطة بهذا الاسم Sub Report() Dim WS As Worksheet, SH As Worksheet Dim I As Long, lRow As Long, LR As Long Set WS = Sheets("نور البيان "): Set SH = Sheets("Report") lRow = 6 Application.ScreenUpdating = False With SH.Range("D6:K1000") .ClearContents: .Interior.Color = xlNone End With Call UniqueNames For I = 7 To 506 If WS.Cells(I, "C") = SH.Cells(3, "C") Then WS.Cells(I, "C").Offset(, 1).Resize(1, 8).Copy SH.Cells(lRow, "D").PasteSpecial xlPasteValues lRow = lRow + 1 End If Next I SH.Range("D7:H1000").ClearContents LR = SH.Cells(Rows.Count, "I").End(xlUp).Row + 1 With SH.Range("I" & LR) .Formula = "=SUM(I6:I" & LR - 1 & ")": .Value = .Value: .Interior.Color = 10092441 If .Value = SH.Range("H6") Then MsgBox "تم سداد المبلغ بالكامل", 64 Else MsgBox "المبلغ لم يتم سداده بالكامل ما زال هناك أقساط متبقية", vbExclamation End If End With SH.Range("C3").Select Application.CutCopyMode = False Application.ScreenUpdating = True End Sub Sub UniqueNames() Dim Rng As Range Dim Dn As Range Dim Dic As Object With Sheets("نور البيان ") Set Rng = .Range("C7:C506") End With Set Dic = CreateObject("Scripting.Dictionary") Dic.CompareMode = vbTextCompare For Each Dn In Rng If Not IsEmpty(Dn) Then Dic(Dn.Value) = Empty Next Dn Sheets("Report").Columns(15).ClearContents Sheets("Report").Range("O1").Resize(Dic.Count, 1).Value = Application.Transpose(Dic.keys) End Sub Report Summary.rar

هلا والله

عذرا فقد تم الرفع مرتان و هذا هو الملف test.rar

السلام عليكم اخي العزيز ان ماتطلبه بالفعل موجود بالملف الزر الاول تم عمله لانه يمكن اسعماله في اي موقف ليكون به المرونه لعمل اي اضافه داخل الملف و لعمل ما تريده انت الان اضف بالزر الاول عدد الصفحات التي تريد و هي 356 في طلبك وعند اضافتها ستجدها مسلسله اليس كذلك تمام الان اضغط الزر الثاني و هو تغير الاسماء و اعلمني بالنتيجه مرفق الملف مرة ثانيه لاني وجدت رسالة خطا تم تعديله تحياتي rename_and_color3.rar