جعفر الطريبق

لعبة جميلة لكن ياريت لو كان بامكان العمل على أكثر من صورة واحدة .. البرنامج كان سيكون أحلى لو مثلا كان بامكان تحميل الصور من الجهاز الى الفورم بشكل ديناميكي ثم تقطيع الصور بالكود VBA الى مثلا 10 أو 20 أو أو أو قطعة حسب رغبة المستخدم و الصعوبة المطلوبة .. و كدالك وضع Timer ساعة لحساب الوقت أنا بصدد كتابة الكود .. لو توصلت الى نتيجة سأنشرها هنا ان شاء الله

الاستاد الفاضل ياسر ... أولا على سلامتك و أدعو الله أن تكون قد شفيت من المرض جرب : VBA.VarPtr

شكرا جزيلا على الردود و التشجيعات في ما يلي بعض الاضافات و التعديلات على الكود لاستيعاب سيناريو تحديث خلفية الفورم تلقائيا عند تغيير الصفحات و الملفات في حالة اظهار الفورم Modeless كما أنني غيرت ال ScrollBar من اليمين الى اليسار ملف للتحميل: https://app.box.com/s/v1kf2m5ukw2mqfcmx86bwujgbr1xjnfw الكود المعدل : Option Explicit Private WithEvents oAppEvents As Application 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 GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type uPicDesc Size As Long Type As Long hPic As Long hPal As Long End Type Private Type BLENDFUNCTION BlendOp As Byte BlendFlags As Byte SourceConstantAlpha As Byte AlphaFormat As Byte End Type Private Type LOGBRUSH lbStyle As Long lbColor As Long lbHatch As Long End Type Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 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 AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length 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 GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function GetClientRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) 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 OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long Private Declare Function SetBkMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nBkMode As Long) As Long Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long Private Const PICTYPE_BITMAP = &H1 Private Const SRCCOPY = &HCC0020 Private Const AC_SRC_OVER = &H0 Private Const OPAQUE = &H2 Private Const GWL_EXSTYLE = (-20) ' Private Const WS_EX_LAYERED = &H80000 Private Const LWA_ALPHA = &H2 Private tRect As RECT Private hInitialDCMemory As Long Private frmHwnd As Long Private frmDc As Long Private hBrush As Long Private hBmp As Long Private bytScrollBarVal As Byte Private Sub UserForm_Initialize() Dim LB As LOGBRUSH Dim Realcolor As Long Dim tRed As OLE_COLOR, tGreen As OLE_COLOR, tBlue As OLE_COLOR 'hook the wb events Set oAppEvents = Application 'setup form controls ScrollBar1.Min = 0 ScrollBar1.Max = 255 ScrollBar1.SmallChange = 3 ScrollBar1.Value = ScrollBar1.Max ScrollBar1.BackColor = vbCyan Label1.Font.Bold = True Label1.BackStyle = fmBackStyleTransparent CommandButton1.Caption = "Close" CommandButton1.Font.Bold = True Me.Caption = "Adjustable Transparent UserForm -- (Client Area)" 'retrieve the form hwnd and DC frmHwnd = FindWindow(vbNullString, Me.Caption) frmDc = GetDC(frmHwnd) 'convert system color to RGB TranslateColor Me.BackColor, 0, Realcolor tRed = Val(CStr(Realcolor And &HFF&)) tGreen = Val(CStr((Realcolor And &HFF00&) / 2 ^ 8)) tBlue = Val(CStr((Realcolor And &HFF0000) / 2 ^ 16)) LB.lbColor = RGB(tRed, tGreen, tBlue) 'create a memory DC and store the initial form backColor in it for later blending hBrush = CreateBrushIndirect(LB) GetWindowRect frmHwnd, tRect hInitialDCMemory = CreateCompatibleDC(frmDc) With tRect hBmp = CreateCompatibleBitmap(frmDc, .Right - .Left, .Bottom - .Top) End With Call SelectObject(hInitialDCMemory, hBmp) SetBkMode hInitialDCMemory, OPAQUE FillRect hInitialDCMemory, tRect, hBrush End Sub Private Sub UserForm_Layout() Call UpdateFormPicture End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 'cleanUp DeleteObject hBrush DeleteObject hBmp Set oAppEvents = Nothing End Sub Private Sub UpdateFormPicture() Dim IID_IDispatch As GUID Dim uPicinfo As uPicDesc Dim IPic As IPicture Dim tPt As POINTAPI Dim BF As BLENDFUNCTION Dim lBF As Long Dim scrDc As Long Dim frmClientWid As Long Dim frmClientHgt As Long Dim hDCMemory As Long 'Update Label with current Transparency rate Me.Label1.Caption = "Transparency : " & (100 * Me.ScrollBar1.Value \ 255) & "%" 'brievely make the form fully transparent in order to capture the screen area underneath the form SetWindowLong frmHwnd, GWL_EXSTYLE, GetWindowLong(frmHwnd, GWL_EXSTYLE) Or WS_EX_LAYERED SetLayeredWindowAttributes frmHwnd, 0, 0, LWA_ALPHA scrDc = GetDC(0) SetLayeredWindowAttributes frmHwnd, 0, 255, LWA_ALPHA 'retrieve the form's client dimensions GetClientRect frmHwnd, tRect With tRect frmClientWid = .Right - .Left frmClientHgt = .Bottom - .Top End With 'create a memory DC to hold the screen area underneath the form hDCMemory = CreateCompatibleDC(scrDc) hBmp = CreateCompatibleBitmap(scrDc, frmClientWid, frmClientHgt) Call SelectObject(hDCMemory, hBmp) tPt.X = tRect.Left: tPt.Y = tRect.Top ClientToScreen frmHwnd, tPt Call BitBlt(hDCMemory, 0, 0, frmClientWid, frmClientHgt, scrDc, tPt.X, tPt.Y, SRCCOPY) 'blend the form's initial backcolor with the screen image underneath the form With BF .BlendOp = AC_SRC_OVER .BlendFlags = 0 .SourceConstantAlpha = bytScrollBarVal .AlphaFormat = 0 End With RtlMoveMemory lBF, BF, 4 AlphaBlend hDCMemory, 0, 0, frmClientWid, frmClientHgt, hInitialDCMemory, 0, 0, frmClientWid, frmClientHgt, lBF 'Set the Form's Picture property to the resulting blended memory Bitmap With IID_IDispatch .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With With uPicinfo .Size = Len(uPicinfo) ' .Type = PICTYPE_BITMAP .hPic = hBmp .hPal = 0 End With OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic Set Me.Picture = IPic 'cleanUp ReleaseDC frmHwnd, frmDc DeleteDC hDCMemory ReleaseDC 0, scrDc End Sub Private Sub ScrollBar1_Change() bytScrollBarVal = 255 - ScrollBar1.Value Call UpdateFormPicture End Sub Private Sub ScrollBar1_Scroll() bytScrollBarVal = 255 - ScrollBar1.Value Call UpdateFormPicture End Sub Private Sub CommandButton1_Click() Unload Me End Sub 'Application events Private Sub oAppEvents_SheetActivate(ByVal Sh As Object) Call UpdateFormPicture End Sub Private Sub oAppEvents_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Call UpdateFormPicture End Sub Private Sub oAppEvents_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window) Call UpdateFormPicture DoEvents End Sub Private Sub oAppEvents_WorkbookActivate(ByVal Wb As Workbook) Call UpdateFormPicture DoEvents End Sub

السلام عليكم كما تعلمون أثير موضوع جعل الفورم شفافا في المنتدى مؤخرا ... الموضوع على الرابطان: http://www.officena.net/ib/topic/63786-كود-لجعل-الفورم-شفاف/ http://www.officena.net/ib/topic/63770-transparent-userform-فورم-شفاف/ الكود في الرابط الأول يمكننا من التحكم في درجة شفافية الفورم لكن المشكلة هي أن الشفافية تطال اطار الفورم و ال TitleBar و جميع الكونترولات و كل شيئ داخل الفورم و في النهاية مع زيادة درجات الشفافية كل شيئ يختفي من على الشاشة ! أما الكود في الرابط الثاني فان الشفافية لا تطال الا خلفية الفورم و يبقى اطار الفورم ظاهرا و أيضا كل الكونترولات - ممتاز ... لكن المشكلة هي أنه لا يمكن الزيادة أو النقصان في درجة الشفافية اذن المطلوب هو التمكن من جعل الفورم شفافا مع امكانية الزيادة و النقصان في درجة الشفافية لكن بدون اخفاء اطار الفورم و الكونترولات التي بداخله أي اعمال خاصية الشفافية على خلفية الفورم فقط هده اشكالية طالما حيرتني كما أنه موضوع مطلوب حله من طرف العديد من مستخدمي و مبرمجي الاكسيل و تطبيقات الأوفيس في منتديات البرمجة لكن لم أجد أي حل حتى الأن الحمد لله و بعد يومين من التجريب و الاصرار يبدو أنني توصلت الى حل (أو هكدا أتمنى) طبعا الكود لا يعمل على الأوفيس 64Bit ... لكي يعمل ينبغي تعديل الكود لكن ليس لدي Office 64Bit لكي أجرب و أقوم بالاختبارات الازمة الكود يعمل جيدا على ال Modal و ال Modeless فورم ملف للتحميل : https://app.box.com/s/9tj2ipj4jc3rygi8hqkbiw14pde0ggu9 الكود: أضف فورم و أضف الى الفورم CommandButton1 و Label1 و ScrollBar1 ثم ضع الكود التالي في اليوزرفورم موديول: 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 GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type uPicDesc Size As Long Type As Long hPic As Long hPal As Long End Type Private Type BLENDFUNCTION BlendOp As Byte BlendFlags As Byte SourceConstantAlpha As Byte AlphaFormat As Byte End Type Private Type LOGBRUSH lbStyle As Long lbColor As Long lbHatch As Long End Type Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 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 AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length 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 GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function GetClientRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) 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 OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long Private Declare Function SetBkMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nBkMode As Long) As Long Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long Private Const PICTYPE_BITMAP = &H1 Private Const SRCCOPY = &HCC0020 Private Const AC_SRC_OVER = &H0 Private Const OPAQUE = &H2 Private Const GWL_EXSTYLE = (-20) ' Private Const WS_EX_LAYERED = &H80000 Private Const LWA_ALPHA = &H2 Private tRect As RECT Private hInitialDCMemory As Long Private frmHwnd As Long Private frmDc As Long Private hBrush As Long Private hBmp As Long Private bytScrollBarVal As Byte Private Sub UserForm_Initialize() Dim LB As LOGBRUSH Dim Realcolor As Long Dim tRed As OLE_COLOR, tGreen As OLE_COLOR, tBlue As OLE_COLOR 'setup form controls ScrollBar1.Min = 0 ScrollBar1.Max = 255 ScrollBar1.SmallChange = 3 ScrollBar1.BackColor = vbCyan Label1.Font.Bold = True Label1.BackStyle = fmBackStyleTransparent CommandButton1.Caption = "Close" CommandButton1.Font.Bold = True Me.Caption = "Adjustable Transparent UserForm -- (Client Area)" 'retrieve the form hwnd and DC frmHwnd = FindWindow(vbNullString, Me.Caption) frmDc = GetDC(frmHwnd) 'convert system color to RGB TranslateColor Me.BackColor, 0, Realcolor tRed = Val(CStr(Realcolor And &HFF&)) tGreen = Val(CStr((Realcolor And &HFF00&) / 2 ^ 8)) tBlue = Val(CStr((Realcolor And &HFF0000) / 2 ^ 16)) LB.lbColor = RGB(tRed, tGreen, tBlue) 'create a memory DC and store the initial form backColor in it for later blending hBrush = CreateBrushIndirect(LB) GetWindowRect frmHwnd, tRect hInitialDCMemory = CreateCompatibleDC(frmDc) With tRect hBmp = CreateCompatibleBitmap(frmDc, .Right - .Left, .Bottom - .Top) End With Call SelectObject(hInitialDCMemory, hBmp) SetBkMode hInitialDCMemory, OPAQUE FillRect hInitialDCMemory, tRect, hBrush End Sub Private Sub UserForm_Layout() Call UpdateFormPicture End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 'cleanUp DeleteObject hBrush DeleteObject hBmp End Sub Private Sub UpdateFormPicture() Dim IID_IDispatch As GUID Dim uPicinfo As uPicDesc Dim IPic As IPicture Dim tPt As POINTAPI Dim BF As BLENDFUNCTION Dim lBF As Long Dim scrDc As Long Dim frmClientWid As Long Dim frmClientHgt As Long Dim hDCMemory As Long 'Update Label with current Transparency rate Me.Label1.Caption = "Transparency : " & 100 - (100 * Me.ScrollBar1.Value \ 255) & "%" 'brievely make the form fully transparent in order to capture the screen area underneath the form SetWindowLong frmHwnd, GWL_EXSTYLE, GetWindowLong(frmHwnd, GWL_EXSTYLE) Or WS_EX_LAYERED SetLayeredWindowAttributes frmHwnd, 0, 0, LWA_ALPHA scrDc = GetDC(0) SetLayeredWindowAttributes frmHwnd, 0, 255, LWA_ALPHA 'retrieve the form's client dimensions GetClientRect frmHwnd, tRect With tRect frmClientWid = .Right - .Left frmClientHgt = .Bottom - .Top End With 'create a memory DC to hold the screen area underneath the form hDCMemory = CreateCompatibleDC(scrDc) hBmp = CreateCompatibleBitmap(scrDc, frmClientWid, frmClientHgt) Call SelectObject(hDCMemory, hBmp) tPt.X = tRect.Left: tPt.Y = tRect.Top ClientToScreen frmHwnd, tPt Call BitBlt(hDCMemory, 0, 0, frmClientWid, frmClientHgt, scrDc, tPt.X, tPt.Y, SRCCOPY) 'blend the form's initial backcolor with the screen image underneath the form With BF .BlendOp = AC_SRC_OVER .BlendFlags = 0 .SourceConstantAlpha = bytScrollBarVal .AlphaFormat = 0 End With RtlMoveMemory lBF, BF, 4 AlphaBlend hDCMemory, 0, 0, frmClientWid, frmClientHgt, hInitialDCMemory, 0, 0, frmClientWid, frmClientHgt, lBF 'Set the Form's Picture property to the resulting blended memory Bitmap With IID_IDispatch .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With With uPicinfo .Size = Len(uPicinfo) ' .Type = PICTYPE_BITMAP .hPic = hBmp .hPal = 0 End With OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic Set Me.Picture = IPic 'cleanUp ReleaseDC frmHwnd, frmDc DeleteDC hDCMemory ReleaseDC 0, scrDc End Sub Private Sub ScrollBar1_Change() bytScrollBarVal = ScrollBar1.Value Call UpdateFormPicture End Sub Private Sub ScrollBar1_Scroll() bytScrollBarVal = ScrollBar1.Value Call UpdateFormPicture End Sub Private Sub CommandButton1_Click() Unload Me End Sub

الأستاد الفاضل مختار حسين لست متأكدا من سبب عدم عمل الملف عندك .. أحيانا بعض ال API Functions لا تشتغل على ال Windows 7 للأسف ليس عندي جهاز يشتغل على ال Windows 7 لكي أجرب الكود

أستاذى الفاضل حسين يبدو أنني لم أوفق في التعبير عما أقصده الملف لا يعمل عندي لأن الفورم يحتوي على Slider Control و هدا الكونترول لا يوجد في ال MSFORMS Lybrary ... و هدا ال OCX Control أي ال Slider Control لا يوجد بالضرورة في كل جهاز فأنا مثلا ليس لدي هدا الكونترول .. لتفادي مثل هده المشاكل من الأفضل دائما استعمال Default Controls .. الكود أدناه يستعمل ال ScrollBar Control الدي هو موجود دائما مع الأكسيل فورم ملف للتحميل : https://app.box.com/s/jff2a32tl4x5uoyoowbi16eb39ku3yrz 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 crey As Byte, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private Const GWL_EXSTYLE = (-20) Private Const WS_EX_LAYERED = &H80000 Private Const LWA_ALPHA = &H2& Private hwnd As Long Private bytOpacity As Byte Private Sub UserForm_Initialize() hwnd = FindWindow("ThunderDFrame", Me.Caption) Call SetWindowLong(hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED) Call SetLayeredWindowAttributes(hwnd, 0, 255, LWA_ALPHA) ScrollBar1.Min = 0 ScrollBar1.Max = 255 ScrollBar1.SmallChange = 3 Label1.Caption = "Transparency : " & 0 & "%" bytOpacity = ScrollBar1.Max End Sub Private Sub ScrollBar1_Change() Call AdjustFormTransparency End Sub Private Sub ScrollBar1_Scroll() Call AdjustFormTransparency End Sub Private Sub AdjustFormTransparency() bytOpacity = 255 - ScrollBar1.Value Call SetLayeredWindowAttributes(hwnd, 0, bytOpacity, LWA_ALPHA) Label1.Caption = "Transparency : " & 100 - (100 * bytOpacity \ 255) & "%" End Sub التحدي الحقيقي هو كيف يمكن التحكم في درجة شفافية الفورم كما فعلنا هنا لكن بدون اخفاء الكونترولات الموجودة داخل الفورم أو ال TitleBar كما هو مطروح في موضوع الرابط التالي : http://www.officena.net/ib/topic/63770-transparent-userform-فورم-شفاف/

الكود في الملف يحتاج الى كونترول أو dll .. فهو لا يشتغل عندي لكن في الحقيقة جعل الفورم شفاف مع التحكم في درجة الشفافية لا يحتاج الى أي كونترولات أو Com Dlls ثم هنالك فرق بين شفافية الفورم في االرابط http://www.officena.net/ib/topic/63770-transparent-userform-فورم-شفاف/ و الدي يعمل الشفافية على وسط الفورم فقط Client Area و يبقي على الكونترولات و شريط العنوان TitleBar و بين الكود في الرابط Userform_.zip و اللدي يخفي الشريط و الكونترولات و كل شيئ

للتدكير فقط الكود الدي تفضل به الاستاد مختار حسين محمود لا يمنع من تكبير أو تصغير الأعمدة و الصفوف باستخدام الماوس أو عن طريق Home Tab => Cells =>Format=>Column Height منع تكبير أو تصغير الأعمدة و الصفوف بدون حماية الصفحة و اعتمادا على الكود ليس أمرا سهلا و يتطلب اعمال تقنية ال SubClassing مرة أخرى يا أستاد عمار .. يمكن جعل الصفحة الأولى واجهة بها اتباطات تشعبية رغم تطبيق حماية على الصفحة.. قبل تطبيق حماية الصفحة يمكن تغيير خاصة ال Locked للخلايا و عند تطبيق الحماية الأكسيل يسمح لك اختيار العديد من الخاصيات

هل تقصد أنك تريد ايقاف خاصية التحكم بتكبير و تصغير الأعمدة و الصفوف بدون عمل حماية للصفحة و لو الجواب نعم هل هنالك سبب لعدم ارادة اعمال الحماية

ان شاء الله لو اشتريت قريبا جهاز عليه الويندوز 64 بيت سأعدل كل أكواد الAPI و عندئد سيكون أسهل علي أن أشرح كيف يعمل الكود و كيف تتعامل ال API Functionsمع الميموري Memory

يمكن لك أن تطبق الحماية للصفحة و بدالك لا يمكن للمستخدم تكبير أو تصغير الأعمدة و الصفوف Sheet ==> Protect

تفضل الملف في الرابط التالي نمودج بسيط يبين كيف يستعمل ال التاب ستريب كونترول بدل ال ميلتيبيج https://app.box.com/s/6iin0p6x29uzfmtxqlcriyeoa5sdfna1

ردا على الأستاد مختار حسين محمود الملحوظة الاولى : صعب أن أعرف لمادا لم يظهر عندك الفورم كما في الصورة .. الكود جربه العديد من المستخدمين على 32 Bit و اشتغل تمام . الملحوظة الثانية : نعم تعديل ال Windows API declarations لا يتطلب جهازا جديدا بل نسخة ويندوز 64 بت فقط .. و هدا ما كنت أقصده و ان خانني التعبير .. أفكر في اقتناء جهاز جديد و عليه الويندوز 64 بت كي أتمكن من تجريب و تعديل الكثير من الكودات التي تستخدم ال API Functions الطلب : يصعب علي شرح هدا الموضوع أو غيره من المواضيع التقنية باللغة العربية ... فأنا لم يسبق لي أن اشتغلت باالاكسيل أو بالبرنجة عموما الا بالانجليزية و قاموسي اللغوي العربي ضعيف جدا ... أقترح عليك الرابط التالي : http://www.jkp-ads.com/articles/apideclarations.asp نعم الرابط بالانجليزي و لكن الاسلوب المستخدم بسيط و يشرح الموضوع بطريقة سهلة و مفصلة .. أتمنى أن يعجبك

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

نعم يا أستادي الفاضل ... بالاضافة الى أن ال ActiveControl Property موجودة عند الفورم و عند الفرييم أيضا

كود لجعل الفورم شفاف مع الابقاء على شريط عنوان الفورم و اطاره و على جميع الكونترولات بداخله ملف للتحميل : 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

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

قبل شهور كنت قد كتبت هدا الكود الدي يعطي للمستخدم امكانية التحكم في لون ال 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

ليس ضروريا أن يتم الاشارة الى الفرييم داخل الكود ... لو السطر التالي لا ينتج عنه خطأ ابتداء من الدورة الثانية في ال 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

جرب الكود التالي مرة واحدة فقط Sub HideZeroValues() Sheets(1).Range("B3:D24").NumberFormat = "0;-0;;@" End Sub

اضف الكود التالي الى الزر الموجود في شيت البحث Worksheets("الاكواد").Rows(1).Find(Range("E2")).EntireColumn.Find(Range("A2")).Resize(, 2).Interior.Color = vbRed

الكود بالليبل و بحدث ال TextBox Exit لن يحقق المطلوب لأن حدث ال Exit لا يقع عند دخول اللييبل الكود التالي أسهل و أقصر و يشتغل بغض النظر عن عدد ال textboxes Private Sub Label1_Click() If TypeName(ActiveControl) = "TextBox" Then If Len(ActiveControl) = 0 Then ActiveControl = Date Else MsgBox "Date already entered in TextBox : '" & ActiveControl.Name & "'" End If Else MsgBox "You need to select a TextBox first" End If End Sub

للتذكير فقط ... تغيير نسبة الأمان و ال Macro Security Settings للمستخدم عبر الكود مسألة غير مناسبة في أغلب الأحيان ... كما أن برمجة ال Registry أمر لا يخلو من الخطورة

لا أعتقد أنه ممكن التمييز بين الملف الأصلي و النسخة الكوبي ... و ما يجعل الأمر أكثر صعوبة هو امكانية عمل كوبي لملف الاكسيل بدون فتح الاكسيل أي مباشر عبر ال Shell ... الحل الوحيد الدي يخطر ببالي هو عمل برنامج VBScript او VB6 يشتغل تلقائيا عند تشغيل الجهاز StartUp و هدا البرنامج وظيفته هي مراقبة حدث ال File Copy وراء الكواليس بحيث عند عمل كوبي للملف يتم تحديد و تخزين أسماء الملفين الأصلي و النسخة و بالتالي التمييز بينهما .. للأسف هده الفكرة شوية معقدة أكثر من اللازم