جعفر الطريبق

استاذ مختار لقد جربت الملف اللذي أرفقته لكن عند تحريك الماوس فوق الشكل (Test) لا يظهر الليبل شكرا

السلام عليكم مبروك الأستاذ ياسر فتحي على الترقية المستحقة

استاذ مختار حسين ... فكرت ادخال دالة ال Hyperlink في الخلايا الموجودة مباشرة تحت الشكل (Shape) ... طبعا هذه الخلايا ينبغي أن تكون خالية و غير مستعملة ...بدأت في كتابة الكود و يبدو جيدا لو توصلت الى نتيجة محترمة سأتشر الكود هنا

بارك الله فيك أستاذ مختار حسين هل فكرت في تطبيق هذه الفكرة على الأشكال (Shapes)أو الأزرار (Forms Buttons) عوض الخلايا بحيث عند تحريك الماوس فوق الشكل او الزر تظهر رسالة معينة

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

السلام عليكم و بارك الله فيكم جميعا على الردود الطيبة الدالة Hyperlink تتقبل ماكرو في ال (First Argument ) و نتفذها عند تحريك الماوس فوق الخلية و هو حسب علمي أمر غير مقصود و غير موثق من طرف مايكروسوفت .. الكود يستغل هذه الخاصية ..كل ما يقوم به الكود هو تغيير لون الخلية و اظهار الصور المخفية مسبقا بعد تحديد مكانها قرب الخلية الملف يستعمل أسماء Named Ranges مطابقة لأسماء الصور لاستدعاء الصور المناسبة استعملت ال GetCursorPos API لجعل عملية اظهار و اخفاء الصور عملية سلسة و سريعة للتذكير هنالك طرق أخرى أكثر تقليدية لانجاز مثل هذا العمل لكنها أكثر تعقيدا و أحيانا تبطئ الاكسيل

السلام عليكم ملف للتحميل : https://app.box.com/s/v94a80af0wlm284d057fhqsjeqxdpd1y الكود التالي يعتمد طريقة فريدة و غريبة بواسطة دالة ال HYPERLINK 1- الكود في موديول عادي : Option Explicit Private Type POINTAPI x As Long y As Long End Type #If VBA7 And Win64 Then Private Declare PtrSafe Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long #Else Private Declare Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long #End If Private ThisCell As Range Private myShape As Shape Private linitialColorIndex As Long Private linitialFontColorIndex As Long Public Sub MyMouseOverEvent_Hyplnk() Set ThisCell = Application.Caller With ThisCell Set ThisWorkbook.oWsh = .Worksheet If .Interior.ColorIndex = 6 Then .Interior.ColorIndex = linitialColorIndex If .Font.ColorIndex = 3 Then .Font.ColorIndex = linitialFontColorIndex linitialColorIndex = .Interior.ColorIndex linitialFontColorIndex = .Font.ColorIndex .Interior.ColorIndex = 6 .Font.ColorIndex = 3 Set myShape = .Parent.Shapes(Replace(.Name.Name, "_", "")) myShape.Left = .Offset(0, 2).Left + 2 myShape.Top = .Offset(0, 2).Top + 1 myShape.Width = .Offset(0, 2).Width - 2 myShape.Height = .Offset(0, 2).Height - 2 myShape.OnAction = "Dummy" myShape.Visible = msoTrue Call MouseExit End With End Sub Private Sub Dummy() End Sub Private Sub MouseExit() Dim tPt As POINTAPI Do GetCursorPos tPt If TypeName(ActiveWindow.RangeFromPoint(tPt.x, tPt.y)) <> "Range" Then Exit Do If ThisCell.Address <> ActiveWindow.RangeFromPoint(tPt.x, tPt.y).Address Then Exit Do DoEvents Loop ThisCell.Interior.ColorIndex = linitialColorIndex ThisCell.Font.ColorIndex = linitialFontColorIndex Set ThisCell = Nothing myShape.Visible = msoFalse End Sub 2- الكود في ThisWorkbook Module : Option Explicit Public WithEvents oWsh As Worksheet Private Sub Workbook_Open() Set oWsh = Sheets(1) End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim oShp As Shape On Error Resume Next For Each oShp In oWsh.Shapes oShp.Visible = msoFalse Next End Sub Private Sub oWsh_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Cancel = True End Sub Private Sub oWsh_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Cancel = True End Sub

بارك الله فيك يا اسناذ ابراهيم

واجهة جميلة

بعد اذن الأساتذة الكرام تفضل الملف التالي : https://app.box.com/s/u36b81zd0oh7rxrlo3gvzfqupm9f2q7x

تفضل يا أستاذ أبو أمين الملف معدل https://app.box.com/s/lp1z6e0ownqlc2yfpfwlmd7szeb71x0o

كذالك و بنفس الطريقة يمكن اضافة يوم الأسبوع بالحروف العربية الى Label11 كالنالي ; 1- أضف دالة جديدة و لنعطيها اسم DayNameArabic Function DayNameArabic(InputDate As Date) Dim DayNumber As Integer DayNumber = Weekday(InputDate, vbSunday) Select Case DayNumber Case 1 DayNameArabic = ChrW(&H627) & ChrW(&H644) & ChrW(&H623) & ChrW(&H62D) & ChrW(&H62F) Case 2 DayNameArabic = ChrW(&H627) & ChrW(&H644) & ChrW(&H625) & ChrW(&H62B) & ChrW(&H646) & ChrW(&H64A) & ChrW(&H646) Case 3 DayNameArabic = ChrW(&H627) & ChrW(&H644) & ChrW(&H62B) & ChrW(&H644) & ChrW(&H62B) & ChrW(&H627) & ChrW(&H621) Case 4 DayNameArabic = ChrW(&H627) & ChrW(&H644) & ChrW(&H623) & ChrW(&H631) & ChrW(&H628) & ChrW(&H639) & ChrW(&H627) & ChrW(&H621) Case 5 DayNameArabic = ChrW(&H627) & ChrW(&H644) & ChrW(&H62E) & ChrW(&H645) & ChrW(&H64A) & ChrW(&H633) Case 6 DayNameArabic = ChrW(&H627) & ChrW(&H644) & ChrW(&H62C) & ChrW(&H645) & ChrW(&H639) & ChrW(&H629) Case 7 DayNameArabic = ChrW(&H627) & ChrW(&H644) & ChrW(&H633) & ChrW(&H628) & ChrW(&H62A) End Select End Function 2- ثم عدل الكود الموجود في الفورم كالنالي ; Private Sub UserForm_Initialize() Label11.Caption = Label11.Caption & " " & DayNameArabic(Now()) Label2.Caption = DayName(Now()) Label3.Caption = Format(Now(), "dd") Label4.Caption = Format(Now(), "mm") Label5.Caption = Format(Now(), "yyyy") Label6.Caption = Format(DHijri(Now()), "dd") Label7.Caption = HijriMonth(Format(DHijri(Now), "mm")) Label8.Caption = Format(DHijri(Now()), "yyyy") End Sub ملاحظة ربما تحتاج الى توسيع عرض ال Label11 بعض الشيء لكي يظهر كل النص

السلام عليكم بعد اذن الأستاذ ياسر , قم بتغيير الدالة HijriMonth كالنالي : Function HijriMonth(MonthNumber As Integer) Select Case MonthNumber Case 1: HijriMonth = ChrW(&H645) & ChrW(&H62D) & ChrW(&H631) & ChrW(&H645) Case 2: HijriMonth = ChrW(&H635) & ChrW(&H641) & ChrW(&H631) Case 3: HijriMonth = ChrW(&H631) & ChrW(&H628) & ChrW(&H64A) & ChrW(&H639) & " " & ChrW(&H627) & ChrW(&H644) & ChrW(&H623) & ChrW(&H648) & ChrW(&H644) Case 4: HijriMonth = ChrW(&H631) & ChrW(&H628) & ChrW(&H64A) & ChrW(&H639) & " " & ChrW(&H627) & ChrW(&H644) & ChrW(&H62B) & ChrW(&H627) & ChrW(&H646) & ChrW(&H64A) Case 5: HijriMonth = ChrW(&H62C) & ChrW(&H645) & ChrW(&H627) & ChrW(&H62F) & ChrW(&H649) & " " & ChrW(&H627) & ChrW(&H644) & ChrW(&H623) & ChrW(&H648) & ChrW(&H644) Case 6: HijriMonth = ChrW(&H62C) & ChrW(&H645) & ChrW(&H627) & ChrW(&H62F) & ChrW(&H649) & " " & ChrW(&H627) & ChrW(&H644) & ChrW(&H62B) & ChrW(&H627) & ChrW(&H646) & ChrW(&H64A) Case 7: HijriMonth = ChrW(&H631) & ChrW(&H62C) & ChrW(&H628) Case 8: HijriMonth = ChrW(&H634) & ChrW(&H639) & ChrW(&H628) & ChrW(&H627) & ChrW(&H646) Case 9: HijriMonth = ChrW(&H631) & ChrW(&H645) & ChrW(&H636) & ChrW(&H627) & ChrW(&H646) Case 10: HijriMonth = ChrW(&H634) & ChrW(&H648) & ChrW(&H627) & ChrW(&H644) Case 11: HijriMonth = ChrW(&H630) & ChrW(&H648) & " " & ChrW(&H627) & ChrW(&H644) & ChrW(&H642) & ChrW(&H639) & ChrW(&H62F) & ChrW(&H629) Case 12: HijriMonth = ChrW(&H630) & ChrW(&H648) & " " & ChrW(&H627) & ChrW(&H644) & ChrW(&H62D) & ChrW(&H62C) & ChrW(&H629) End Select End Function

السلام عليكم لو افترضنا أن التكست بوكس هو TextBox1 ضع الكود التالي في موديول الفورم Option Explicit Private Const KL_NAMELENGTH = 9 #If Win64 Then Private Declare PtrSafe Function LoadKeyboardLayoutA Lib "user32" (ByVal pwszKLID As String, ByVal flags As Long) As LongPtr Private Declare PtrSafe Function ActivateKeyboardLayoutA Lib "user32" Alias "ActivateKeyboardLayout" (ByVal HKL As LongPtr, ByVal flags As Long) As LongPtr Private Declare PtrSafe Function UnloadKeyboardLayoutA Lib "user32" Alias "UnloadKeyboardLayout" (ByVal HKL As LongPtr) As Long Private Declare PtrSafe Function GetKeyboardLayoutNameA Lib "user32" (ByVal pwszKLID As String) As Long #Else Private Declare Function LoadKeyboardLayoutA Lib "user32" (ByVal pwszKLID As String, ByVal flags As Long) As Long Private Declare Function ActivateKeyboardLayoutA Lib "user32" Alias "ActivateKeyboardLayout" (ByVal HKL As Long, ByVal flags As Long) As Long Private Declare Function UnloadKeyboardLayoutA Lib "user32" Alias "UnloadKeyboardLayout" (ByVal HKL As Long) As Long Private Declare Function GetKeyboardLayoutNameA Lib "user32" (ByVal pwszKLID As String) As Long #End If #If Win64 Then Dim HKLsystem As LongPtr, HKLarabic As LongPtr #Else Dim HKLsystem As Long, HKLarabic As Long #End If Private Sub TextBox1_Enter() ActivateKeyboardLayout HKLarabic End Sub Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) ActivateKeyboardLayout HKLsystem End Sub Private Sub UserForm_Initialize() HKLsystem = LoadKeyboardLayout(GetKeyboardLCID) HKLarabic = LoadKeyboardLayout(1025) End Sub Private Sub UserForm_Terminate() ActivateKeyboardLayout HKLsystem UnloadKeyboardLayout HKLarabic End Sub Private Function GetKeyboardLCID() As Long Dim KLID As String * KL_NAMELENGTH GetKeyboardLayoutNameA KLID GetKeyboardLCID = CLng("&H" & KLID) End Function #If Win64 Then Private Function LoadKeyboardLayout(ByVal LCID As Long) As LongPtr #Else Private Function LoadKeyboardLayout(ByVal LCID As Long) As Long #End If Dim KLID As String * KL_NAMELENGTH KLID = Right(String(KL_NAMELENGTH - 1, "0") & Hex(LCID), KL_NAMELENGTH - 1) & vbNullChar LoadKeyboardLayout = LoadKeyboardLayoutA(KLID, 0) End Function #If Win64 Then Private Function UnloadKeyboardLayout(ByVal HKL As LongPtr) As Boolean #Else Private Function UnloadKeyboardLayout(ByVal HKL As Long) As Boolean #End If UnloadKeyboardLayout = UnloadKeyboardLayoutA(HKL) <> 0 End Function #If Win64 Then Private Function ActivateKeyboardLayout(ByVal HKL As LongPtr) As LongPtr #Else Private Function ActivateKeyboardLayout(ByVal HKL As Long) As Long #End If ActivateKeyboardLayout = ActivateKeyboardLayoutA(HKL, 0) DoEvents End Function

السلام عليكم تفضلوا الكود للتحكم قي درجة شفافية القورم - نسخة 64Bit ملف للتحميل : https://app.box.com/s/m96bzgd2efpp5gr9isl96y4n2xav6rm7 1- كود في موديول الفورم : Option Explicit Private WithEvents oAppEvents As Application Public bytScrollBarVal As Byte 'Userform events Private Sub UserForm_Activate() Call UpdateFormPicture(Me) End Sub Private Sub UserForm_Initialize() Set oAppEvents = Application Call init(Me) End Sub Private Sub UserForm_Layout() Call UpdateFormPicture(Me) End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Set oAppEvents = Nothing Call CleanUp End Sub Private Sub ScrollBar1_Change() Me.bytScrollBarVal = 255 - ScrollBar1.Value Call UpdateFormPicture(Me) End Sub Private Sub ScrollBar1_Scroll() Me.bytScrollBarVal = 255 - ScrollBar1.Value Call UpdateFormPicture(Me) End Sub Private Sub CommandButton1_Click() Unload Me End Sub 'Application events Private Sub oAppEvents_SheetActivate(ByVal Sh As Object) Call UpdateFormPicture(Me) End Sub Private Sub oAppEvents_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Call UpdateFormPicture(Me) End Sub Private Sub oAppEvents_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window) Call UpdateFormPicture(Me) DoEvents End Sub Private Sub oAppEvents_WorkbookActivate(ByVal Wb As Workbook) Call UpdateFormPicture(Me) DoEvents End Sub 2- كود في موديول عادي : 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 PICTDESC Size As Long Type As Long hPic As LongPtr 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 PtrSafe Function ClientToScreen Lib "user32" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare PtrSafe Function AlphaBlend Lib "msimg32.dll" (ByVal hDC As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hDC As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr) Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As Long Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As LongPtr Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hDC As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As LongPtr Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long Private Declare PtrSafe Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As LongPtr, ByVal crey As Byte, ByVal bAlpha As Byte, ByVal dwFlags 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 hInitialDCMemory As LongPtr Private frmHwnd As LongPtr Private frmDc As LongPtr Public Sub init(ByVal oFrm As Object) Dim LB As LOGBRUSH Dim Realcolor As Long Dim tRed As OLE_COLOR, tGreen As OLE_COLOR, tBlue As OLE_COLOR Dim hBmp As LongPtr Dim tRect As RECT Dim hBrush As LongPtr 'setup form controls With oFrm .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 .Caption = "Adjustable Transparent UserForm -- (Client Area)" End With 'retrieve the form hwnd and DC frmHwnd = FindWindow("ThunderDFrame", oFrm.Caption) frmDc = GetDC(frmHwnd) 'convert system color to RGB TranslateColor oFrm.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 DeleteObject hBrush DeleteObject hBmp ReleaseDC frmHwnd, frmDc End Sub Public Sub UpdateFormPicture(ByVal oFrm As Object) Dim BF As BLENDFUNCTION Dim lBF As Long Dim IID_IDispatch As GUID Dim uPicinfo As PICTDESC Dim IPic As IPicture Dim tPt As POINTAPI Dim hBmp As LongPtr Dim scrDc As LongPtr Dim tRect As RECT Dim hDCMemory As LongPtr Static frmClientWid As Long Static frmClientHgt As Long Static l As Long oFrm.Label1.Caption = "Transparency : " & (100 * oFrm.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 If l Mod 4 = 0 Then SetLayeredWindowAttributes frmHwnd, 0, 0, LWA_ALPHA End If l = l + 1 scrDc = GetDC(0) hDCMemory = CreateCompatibleDC(scrDc) hBmp = CreateCompatibleBitmap(scrDc, frmClientWid, frmClientHgt) '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 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) 'make the form opaque again SetLayeredWindowAttributes frmHwnd, 0, 255, LWA_ALPHA 'blend the form's initial backcolor with the screen image underneath the form With BF .BlendOp = AC_SRC_OVER .BlendFlags = 0 .SourceConstantAlpha = oFrm.bytScrollBarVal .AlphaFormat = 0 End With CopyMemory 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 oFrm.Picture = IPic DeleteDC hDCMemory ReleaseDC 0, scrDc oFrm.Repaint End Sub Public Sub CleanUp() DeleteDC hInitialDCMemory End Sub

مشكور يا أستاذ ياسر خليل .. لقد اشنريت جهازا حديدا يشتغل على الويندوز 64 اوقيس 2010 و بدأئت أعدل في بعض الأكواد

السلام عليكم تفضلوا التسخة 64 بيت ... كتبت الكود و جربته على ال Windows7 64bit Office10 64bit ملف للتحميل: https://app.box.com/s/cvjs3lt381ts805zu8v1uzu0ooxu4i80 الكود في ستاندر موديول Option Explicit 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 LongPtr End Type Private Declare PtrSafe Function CreateWindowEx Lib "user32" 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 LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As LongPtr Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long Private Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String) As Long Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long Private Declare PtrSafe 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 PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long Private Const WS_CHILD = &H40000000 Private Const WS_CLIPCHILDREN = &H2000000 Private Const WS_CAPTION = &HC00000 Private Const WS_EX_TOPMOST = &H8& Private Const SW_NORMAL = 1 Private Const TRANSPARENT = 1 Private Const SM_CXSCREEN = 0 Private Const SM_CYSCREEN = 1 Private Const COLOR_BTNFACE = 15 Private bWindowExist As Boolean Public Sub Test() If Not bWindowExist Then Call ShowUpdatingMessage( _ Message:="Showing message number : ", _ Title:="Officena", _ HowManyTimes:=10, MessageDelay:=1, _ TOPMOST:=True, TextColor:=vbRed, BackColor:=vbYellow _ ) End If End Sub Private Sub ShowUpdatingMessage( _ ByVal Message As String, _ ByVal Title As String, _ ByVal HowManyTimes As Single, _ Optional ByVal MessageDelay As Single, _ Optional ByVal TOPMOST As Boolean, _ Optional ByVal TextColor As Long, _ Optional ByVal BackColor As Long) Const WIDTH = 250 Const HEIGHT = 120 Dim tRect As RECT Dim tLb As LOGBRUSH Dim t As Single Dim hBrush As LongPtr Dim hwndChild As LongPtr Dim hWndParent As LongPtr Dim hdc As LongPtr Dim iCounter As Integer On Error GoTo CleanUp ' Application.EnableCancelKey = xlErrorHandler hWndParent = CreateWindowEx(IIf(TOPMOST, WS_EX_TOPMOST, 0), "BUTTON", Title, WS_CAPTION + WS_CLIPCHILDREN, _ (GetSystemMetrics(SM_CXSCREEN) - WIDTH) / 2.2, (GetSystemMetrics(SM_CYSCREEN) - HEIGHT) / 2, WIDTH, HEIGHT, 0, ByVal 0, 0, ByVal 0&) hwndChild = CreateWindowEx(0, "STATIC", vbNullString, WS_CHILD, 0, 0, WIDTH, HEIGHT, hWndParent, ByVal 0&, ByVal 0, ByVal 0&) If hwndChild Then bWindowExist = True Application.OnKey "%{F4}", "" ShowWindow hWndParent, SW_NORMAL ShowWindow hwndChild, SW_NORMAL DoEvents hdc = GetDC(hwndChild) SetBkMode hdc, TRANSPARENT If TextColor <> 0 Then SetTextColor hdc, TextColor End If SetRect tRect, 0, 0, WIDTH, HEIGHT tLb.lbColor = IIf(BackColor = 0, GetSysColor(COLOR_BTNFACE), BackColor) hBrush = CreateBrushIndirect(tLb) For iCounter = 1 To HowManyTimes FillRect hdc, tRect, hBrush TextOut hdc, 30, 20, Message, Len(Message) TextOut hdc, 115, 50, CStr(iCounter), Len(CStr(iCounter)) t = Timer Do DoEvents Loop Until Timer - t >= IIf(MessageDelay = 0, 1, MessageDelay) Next End If CleanUp: ReleaseDC hwndChild, 0 DeleteObject hBrush DestroyWindow hwndChild DestroyWindow hWndParent bWindowExist = False Application.OnKey "%{F4}" End Sub

السلام علبكم ملف للتحميل : https://app.box.com/s/72jzyfczsk6bvsedm57h6ycv12agxgv9 نسخة 64 بيت .. حربتها على Windows7 64 bit Office 2010 64 bit - كود في موديول الفورم: PaintingPuzzleGame 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 PICTDESC Size As Long Type As Long hPic As LongPtr hPal As LongPtr End Type Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As LongPtr Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Long, ByVal bErase As Long) As Long Private Declare PtrSafe Function MessageBeep Lib "user32" (ByVal wType As Long) As Long Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare PtrSafe Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags As Long) As Long Private Const PICTYPE_BITMAP = &H1 Private Const SRCCOPY = &HCC0020 Private Const SM_CXSCREEN = 0 Private Const SM_CYSCREEN = 1 Private Const SND_ASYNC = &H1 Private Const SND_FILENAME = &H20000 Private Const SND_LOOP = &H8 Private Const SND_PURGE = &H40 'Module level variables Private oCol As Collection Private oPic As Object Private bScore As Boolean Private bExit As Boolean Private bAbort As Boolean Private InitialFormLeft As Single Private InitialFormTop As Single Private lFrmHwnd As LongPtr Private lCounter As Long Private lTotalImageParts As Long Private lColumns As Long Private lRows As Long Private sLevel As String Private sUserName As String Private vFileName As Variant Private Sub UserForm_Initialize() sUserName = InputBox("Please, enter your name", "Player Name") If Len(sUserName) = 0 And StrPtr(sUserName) <> 0 Then MsgBox "You must enter a player name", vbInformation: End If StrPtr(sUserName) = 0 Then End End Sub Private Sub UserForm_Activate() StartUpPosition = 2 InitialFormLeft = Me.Left InitialFormTop = Me.Top Set oPic = frameSourcePic.Picture lFrmHwnd = FindWindow(vbNullString, Me.Caption) frameSourcePic.BorderStyle = fmBorderStyleSingle frameSourcePic.BorderColor = vbYellow With Me.ComboLevel .AddItem "Easy " & " (3x6 Parts)" .AddItem "low " & " (3x8 Parts)" .AddItem "Medium " & "(4x10 Parts)" .AddItem "High " & "(6x13 Parts)" .ListIndex = 0 End With lblTimer.Caption = "" CBtnAbort.Enabled = False Call EnableControls(True) End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If MsgBox("Are you sure you want to quit ?", vbQuestion + vbYesNo) = vbNo Then Cancel = 1 Exit Sub End If bExit = True End Sub '*************************************************************************************************** 'Event handlers of form's controls Private Sub ComboLevel_Change() Select Case True Case UCase(ComboLevel.Value) Like "EASY*" lRows = 3 lColumns = 6 Case UCase(ComboLevel.Value) Like "LOW*" lRows = 3 lColumns = 8 Case UCase(ComboLevel.Value) Like "MEDIUM*" lRows = 4 lColumns = 10 Case UCase(ComboLevel.Value) Like "HIGH*" lRows = 6 lColumns = 13 End Select sLevel = UCase(ComboLevel.Value) End Sub Private Sub CBtnAbort_Click() Call EnableControls(False) bAbort = True End Sub Private Sub CBtnClose_Click() Unload Me End Sub Private Sub CBtnNewPic_Click() On Error GoTo errHandler vFileName = Application.GetOpenFilename(FileFilter:="Picture Files (*.gif;*.jpg;*.jpeg;*.bmp),*.gif;*.jpg;*.jpeg;*.bmp", _ Title:="Select Picture") If vFileName <> False Then frameSourcePic.Picture = LoadPicture(vFileName) Call DeletePreviousImages End If Exit Sub errHandler: MsgBox Err.Description End Sub Private Sub CBtnStart_Click() Dim oImagePartCls As oImagePartCls Dim oTextBox As msforms.TextBox Dim tRect As RECT Dim tPt1 As POINTAPI, tPt2 As POINTAPI Dim BasePicframeHwnd As Long Dim lImgPartWidth As Long, lImgPartHeight As Long Dim lImgPartLeft As Long, lImgPartTop As Long Dim lColumn As Long, lRow As Long Dim lControlCounter As Long bScore = False bAbort = False Call EnableControls(False) BasePicframeHwnd = frameSourcePic.[_GethWnd] GetWindowRect BasePicframeHwnd, tRect tPt1.x = tRect.Left tPt1.y = tRect.Top tPt2.x = tRect.Right tPt2.y = tRect.Bottom If IsFormClipped(tPt1, tPt2) Then Me.Move InitialFormLeft, InitialFormTop GetWindowRect BasePicframeHwnd, tRect DoEvents End If Call DeletePreviousImages 'add the image parts controls Set oCol = New Collection For lColumn = 1 To lRows For lRow = 1 To lColumns lControlCounter = lControlCounter + 1 Set oImagePartCls = New oImagePartCls Set oImagePartCls.GetForm = Me Set oImagePartCls.PicturePart = Controls.Add("Forms.Image.1", "Image" & lControlCounter) With oImagePartCls.PicturePart .PictureSizeMode = fmPictureSizeModeStretch .BorderStyle = fmBorderStyleSingle .BorderColor = vbYellow .MousePointer = fmMousePointerSizeAll .Width = frameSourcePic.Width / lRows .Height = frameSourcePic.Height / lColumns .Left = frameSourcePic.Left + (((lRow - 1) * (frameSourcePic.Width + 20) / lRows)) .Top = 20 + (((lColumn - 1) * (frameSourcePic.Height + 20) / lColumns)) .ZOrder 0 .ControlTipText = "Drag the Picture down to its corresponding empty frame below" End With oCol.Add oImagePartCls Next Next 'add the textbox holder controls lControlCounter = 0 For lRow = 1 To lColumns For lColumn = 1 To lRows lControlCounter = lControlCounter + 1 Set oTextBox = Controls.Add("Forms.TextBox.1", "TextBox" & lControlCounter) With oTextBox .Enabled = False .BackStyle = fmBackStyleTransparent .BorderStyle = fmBorderStyleSingle .SpecialEffect = fmSpecialEffectEtched .Left = frameSourcePic.Left + frameSourcePic.Width + 80 + lColumn * frameSourcePic.Width / lRows .Top = frameSourcePic.Top + (lRow - 1) * frameSourcePic.Height / lColumns .Width = oImagePartCls.PicturePart.Width .Height = oImagePartCls.PicturePart.Height .ZOrder 1 End With Next Next 'randomly shuffle the image part controls lTotalImageParts = lColumns * lRows Me.Tag = lTotalImageParts ReDim iArray(1 To lTotalImageParts) As Integer ' Call ShufflePictureParts(lTotalImageParts, iArray) 'set the Pic property of each image part lControlCounter = 0 For lColumn = 1 To lColumns For lRow = 1 To lRows With tRect lImgPartWidth = (.Right - .Left) / lRows lImgPartHeight = (.Bottom - .Top) / lColumns lImgPartLeft = .Left + ((lRow - 1) * lImgPartWidth) lImgPartTop = .Top + ((lColumn - 1) * lImgPartHeight) End With lControlCounter = lControlCounter + 1 Controls("image" & iArray(lControlCounter)).Tag = Controls("TextBox" & lControlCounter).Name CropPic lImgPartWidth, lImgPartHeight, lImgPartLeft, lImgPartTop, Me.Controls("image" & iArray(lControlCounter)) InvalidateRect lFrmHwnd, 0, 0 Next Next frameSourcePic.BorderStyle = fmBorderStyleSingle frameSourcePic.BorderColor = vbYellow Call UpdateTimerLabel End Sub '************************************************************************************************* ' Private Supporting routines Private Sub UpdateTimerLabel() Dim ss As Long Dim mm As Long Dim hh As Long Dim sglTimer As Single Const WAV_FILE As String = "C:\WINDOWS\MEDIA\tada.WAV" sglTimer = Timer Do ss = Int(Timer - sglTimer) If ss = 60 Then mm = mm + 1: ss = 0: sglTimer = Timer If mm = 60 Then hh = hh + 1: mm = 0: sglTimer = Timer lblTimer.Caption = Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" DoEvents Loop Until bExit Or bScore Or bAbort If bScore Then PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_LOOP Or SND_ASYNC If MsgBox("Congratulations " & sUserName & " !!" & vbCrLf & vbCrLf & _ "You scored in : " & Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" & vbCrLf & _ "Do you want to save this score to your scores history ?", vbQuestion + vbYesNo) = vbYes Then Call SaveTheScore(hh, mm, ss) End If PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_PURGE End If lblTimer.Caption = "" Call EnableControls(True) Call DeletePreviousImages Set frameSourcePic.Picture = oPic End Sub Private Sub SaveTheScore(ByVal hh As Long, mm As Long, ByVal ss As Long) Dim bProtection As Boolean bProtection = ActiveSheet.ProtectContents If bProtection Then ActiveSheet.Unprotect End If With Cells(Cells.Rows.Count, 1).End(xlUp) .Offset(1, 0) = sUserName .Offset(1, 1) = Now .Offset(1, 2) = IIf(vFileName = Empty, "Default Picture", vFileName) .Offset(1, 3) = sLevel .Offset(1, 4) = Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" End With If bProtection Then ActiveSheet.Protect End If ThisWorkbook.Save End Sub Private Sub CropPic(ByVal nWidth, ByVal nHeight, ByVal x, ByVal y, DestCtrl As Image) Dim hdc As LongPtr Dim hDCMemory As LongPtr Dim hBmp As LongPtr Dim OldBMP As LongPtr Dim IID_IDispatch As GUID Dim uPicinfo As PICTDESC Dim IPic As IPicture hdc = GetDC(0) hDCMemory = CreateCompatibleDC(hdc) hBmp = CreateCompatibleBitmap(hdc, nWidth, nHeight) OldBMP = SelectObject(hDCMemory, hBmp) Call BitBlt(hDCMemory, 0, 0, nWidth, nHeight, hdc, x, y, SRCCOPY) 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 DestCtrl.Picture = IPic ReleaseDC 0, hdc DeleteObject OldBMP DeleteDC hDCMemory End Sub Private Sub ShufflePictureParts(ByVal NumOfPics, ByRef Arr() As Integer) Dim i As Integer, lRandomNumber As Integer, temp As Integer For i = 1 To NumOfPics Arr(i) = i Next i Randomize Timer For i = 1 To NumOfPics lRandomNumber = Int(Rnd * (UBound(Arr) - LBound(Arr) + 1) + LBound(Arr)) temp = Arr(i) Arr(i) = Arr(lRandomNumber) Arr(lRandomNumber) = temp Next i End Sub Private Sub DeletePreviousImages() Dim i As Long Dim oCtl As Control On Error Resume Next If Not oCol Is Nothing Then For i = 1 To oCol.Count Controls.Remove Controls("Image" & i).Name Next For Each oCtl In Me.Controls If TypeName(oCtl) = "TextBox" Then Controls.Remove oCtl.Name End If If TypeName(oCtl) = "Image" Then Controls.Remove oCtl.Name End If Next End If End Sub Private Function IsFormClipped(tLeftTop As POINTAPI, tRightBottom As POINTAPI) As Boolean IsFormClipped = _ tLeftTop.x <= 1 Or tLeftTop.y <= 1 Or tRightBottom.x >= GetSystemMetrics(SM_CXSCREEN) - 1 Or _ tRightBottom.y >= GetSystemMetrics(SM_CYSCREEN) - 1 End Function Private Sub EnableControls(ByVal Bool As Boolean) CBtnAbort.Enabled = Not Bool CBtnNewPic.Enabled = Bool CBtnStart.Enabled = Bool ComboLevel.Enabled = Bool End Sub '************************************************************************************************************* ' Public Methods Public Sub MsgbBeep() MessageBeep &H40& End Sub Public Sub FlashImagePart(ByVal Img As Image, ByVal ct As msforms.TextBox) Dim i As Long Dim t As Single For i = 0 To 1 Img.BorderStyle = fmBorderStyleSingle Img.BorderColor = vbRed t = Timer Do DoEvents Loop Until Timer - t >= 0.1 Img.BorderStyle = fmBorderStyleNone Next End Sub Public Sub CheckIfSuccess() Dim oCtrl As Control Dim lCounter As Long For Each oCtrl In Me.Controls If TypeName(oCtrl) = "Image" Then If InStr(1, oCtrl.Tag, "Success") Then lCounter = lCounter + 1 If lCounter = lTotalImageParts Then bScore = True End If End If End If Next End Sub - الكود في الكلاس موديول : oImagePartCls Option Explicit Public WithEvents PicturePart As msforms.Image Private initialY As Single, initialX As Single Private oUForm As Object Public Property Set GetForm(ByVal vNewValue As Object) Set oUForm = vNewValue End Property Private Sub PicturePart_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) initialX = x: initialY = y PicturePart.ZOrder 0 End Sub Private Sub PicturePart_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) Dim oCtrl As Control Static oPrevCtrl As Control If Button = 1 Then With PicturePart .Move .Left + (x - initialX), .Top + (y - initialY) For Each oCtrl In oUForm.Controls If TypeName(oCtrl) = "TextBox" Then If Not oPrevCtrl Is Nothing Then oPrevCtrl.Enabled = False oPrevCtrl.BackStyle = fmBackStyleTransparent oPrevCtrl.SpecialEffect = fmSpecialEffectEtched End If If .Left + .Width / 2 > oCtrl.Left And .Left + .Width / 2 < oCtrl.Left + oCtrl.Width _ And .Top + .Height / 2 > oCtrl.Top And .Top + .Height / 2 < oCtrl.Top + oCtrl.Height Then oCtrl.Enabled = True oCtrl.BackStyle = fmBackStyleOpaque oCtrl.SpecialEffect = 6 oCtrl.BackColor = vbWhite Set oPrevCtrl = oCtrl Exit For End If End If Next End With End If End Sub Private Sub PicturePart_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) Dim oCtrl As Control For Each oCtrl In oUForm.Controls If TypeName(oCtrl) = "TextBox" Then With PicturePart If .Left + .Width / 2 > oCtrl.Left And .Left + .Width / 2 < oCtrl.Left + oCtrl.Width _ And .Top + .Height / 2 > oCtrl.Top And .Top + .Height / 2 < oCtrl.Top + oCtrl.Height Then .Move oCtrl.Left, oCtrl.Top PicturePart.BorderStyle = fmBorderStyleNone Call oUForm.FlashImagePart(PicturePart, oCtrl) If InStr(1, PicturePart.Tag, oCtrl.Name) Then PicturePart.Tag = PicturePart.Tag & "Success" Else If Right(PicturePart.Tag, 7) = "Success" Then PicturePart.Tag = Mid(PicturePart.Tag, 1, Len(PicturePart.Tag) - 7) End If End If Call oUForm.MsgbBeep Call oUForm.CheckIfSuccess Exit For End If End With End If Next End Sub

السلام عليكم ادهب الى محرر الأكواد و اعمل رايت كليك على الفورم و اختر Export File من القائمة و احفظ الملف (UserForm.frm) في محفظة من اختيارك افتح الملف الثاني و ادهب الى محرر الأكواد و اعمل رايت كليك على ال VBAProject للملف و اختار Import File من القائمة و اختار ملف الفورم الدي حفظته في الخطوة السابقة لو أردت ازالة الفورم نهائيا من الملف الأول بعد اتمام عملية النقل فاعمل كالتالي: ادهب الى محرر الأكواد و اعمل رايت كليك على الفورم و اختر Delete UserForm من القائمة

السلام عليكم أستادي الفاضل أنس دروبي السلوك الطبيعي للاكسيل هو أن يفتح جميع الملفات داخل برنامج أكسيل واحد يعني في نفس ال Excel Instance أما ما يفترض أن يحدث عندما نفتح الملف الدي يحتوي على الكود فهو كالتالي: السيناريو الاول - عندما يكون هنالك ملف أخر أو أكثر مفتوح مسبقا قبل فتح الملف الدي فيه الكود بمجرد ما يفتح الملف فان الكود ينطلق و يبحث هل هنالك ملف أخر مفتوح مسبقا فلو هنالك ملف أخر مفتوح فان الملف صاحب الكود يغلق نفسه بنفسه ثم يفتح نفسه من جديد في نسخة جديدة للاكسيل السيناريو الثاني- عندما ليس هنالك أي ملف أخر مفتوح مسبقا بمجرد فتح الملف فان الكود يبدأ بمراقبة الحدث Application_NewWorkbook و حدث Application_WorkbookOpen بحيث عندما يتم لاحقا فتح ملفا جديدا فان الملف الجديد يغلق نفسه ثم ينفتح نفسه لكن في نسخة جديدة للاكسيل النتيجة المفترضة : في كلا السينارهات الملف الدي فيه الكود يبقى دائما مفتوحا على انفراد في نسخة لوحده فقط و هدا هو المطلوب استادي أنس دروبي .. هل جربت الكود و أعطى النتيجة المطلوبة ? أما في ما يخص مسألة كون الاكسيل يفتح الملفات في شكل نوافد منفصلة عن بعضها البعض كما تفضلت فان هد أمر أخر لا صلة له بما نتحدث عنه هنا لأن رغم انفصال نوافد الملفات الا أن الملفات تكون كلها مفتوحة في نفس نسخة الاكسيل أما ما يفعله الكود هو اجبار الملفات أن تكون مفتوحة في نسخ منفصلة لبرامج الاكسيل ... هنالك فرق بين ال Workbook.Windows و الApplication Instances هنالك شيئ واحد لم انتبه اليه و لم أخده بعين الاعتبار عند كتابة الكود هو في حالة وجود ملف Personal.xls او ملف Addin.xla مفتوح يمكن للكود أن يفشل في تحقيق المطلوب ... لاحقا سأعدل الكود ليأخد هده الحالة في عين الاعتبار ***************************************************************************************************************** في ما يتعلق بسؤالك عن فتح ملف أخر بينما اليوزرفورم مفعل فهل تقصد أن تفتح الملف الأخر عبر كود في اليوزرفورم أم مادا ... السؤال غير واضح لي يا أستادي الفاضل ... حسب معلوماتي و تجربتي فان وجود يوزرفورم مفعل لا يمنع من فتح ملف أخر بطريقة مباشرة ادا كان الفورم مفعلا بطريقة Modeless أو عن طريق الكود سواء كان الفورم مفعلا بطريقة Modeless أو Modal أرجو التوضيح اكثر

بعد ادن الأستاد المحترم عادل حنفي الكود المقترح يعمل Selection لكنه لا يعمل السكرول و لا يدهب الى الخلية المقصودة أقترح الكود البديل التالي Private Sub Workbook_Open() Application.Goto Sheets("Sheet3").Range("H6"), True End Sub

السلام عليم يبدو أنني لم أوفق في شرح وظيفة الكود ... دعني أشرح بطريقة أخرى خطوة خطوة 1- افتح ملفا جديدا و اضف الكود اليه داخل ال ThisWorkbook Module 2- احفظ الملف و اغلقه و اغلق برنامج الاكسيل لو كان الاكسيل لا زال مفتوحا 3- افتح الملف من جديد و اتركه مفتوحا 4- الأن افتح ملفا أخر أيا كان هدا الملف الأخر النتيجة : الأن لديك ملفان مفتوحان لكن عوض أن يكون الملفان مفتوحان في نسخة واحدة مشتركة للاكسل كما هو معهود ستجد أن كل ملف مفتوح لوحده في نسخة منفصلة للاكسيل خاصة به ... بمعنى أخر ستجد أن لديك في المجموع نسختان منفصلتين للاكسيل و ليس نسخة واحدة .... النسخة الأولى للاكسيل موجود فيها الملف الأول (يعني الملف صاحب الكود) و النسخة الثانية فيها الملف الثاني لو فتحت ملفا ثالتا سيحدث نفس الشيئ و هكدا في النهاية الغرض من الكود هو أن يكون الملف الأول يعني الملف المحتوي على الكود دائما مفتوحا وحيدا في نسخة منفصلة للاكسيل أما أي ملف أخر يفتح من قبله أو من بعده فانه سيفتح تلقائيا في برنامج اكسيل منفصل أرجو أن يكون الشرح وافيا

استادي الفاضل ياسر عندما تفتح ملفا معينا ثم بعد دالك تفتح ملفا ثانيا فان الملف الثاني ينفتح في نفس برنامج الاكسيل مع الملف الاول - دالك هو السلوك العادي للاكسيل في تعامله مع فتح الملفات ... الكود موضوع هده المشاركة هدفه هو جعل الملف الثاني (يعني الملف صاحب الكود) ينفتح لوحده في نسخة ثانية على انفراد New Excel instance .. أحيانا المستخدم لا يرغب في أن يكون أكثر من ملف واحد مفتوح و بنفس الطريقة ادا اشتغل الكود فانه لو تم فتح الملف اليتيم أولا (يعني الملف صاحب الكود) ثم بعد دالك فتح ملفا ثانيا فان الملف الثاني ينفتح في نسخة أخرى حيث يبقى الملف الأول دائما وحيدا في الاكسيل

السلام عليكم كما تعلمون لا يوجد في الاكسيل حدث مرتبط بالنسخ أو القص ... هدا كود يملأ دالك الفراغ أضف الكود التالي الى ال ThisWorkbook Module : تنبيه : لكي يبدأ الكود في الاشتغال يجب أولا تنفيد الكود الموجود داخل ال Private Sub Workbook_Open() أو غلق الملف ثم اعادة فتحه Option Explicit Private WithEvents Cmbrs As CommandBars #If VBA7 Then Private Declare PtrSafe Function GetClipboardSequenceNumber Lib "user32" () As Long #Else Private Declare Function GetClipboardSequenceNumber Lib "user32" () As Long #End If Private Sub Workbook_Open() Set Cmbrs = Application.CommandBars End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Set Cmbrs = Nothing End Sub Private Sub Cmbrs_OnUpdate() Dim bCancel As Boolean Dim sClipData As String Static lSequenceNumber As Long On Error Resume Next With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") If lSequenceNumber = GetClipboardSequenceNumber Then Exit Sub lSequenceNumber = GetClipboardSequenceNumber .GetFromClipboard sClipData = .GetText sClipData = Left(sClipData, Len(sClipData) - 2) Select Case True Case Application.CutCopyMode = xlCopy Call Workbook_CellCopy(Selection, sClipData, bCancel) Case Application.CutCopyMode = xlCut Call Workbook_CellCut(Selection, sClipData, bCancel) End Select End With If bCancel Then Application.CutCopyMode = False End Sub 'pseudoevents : '============ Private Sub Workbook_CellCopy(ByVal Target As Range, ByVal ClipboardData As String, ByRef Cancel As Boolean) If MsgBox("You are about to copy the following text to the clipboard:" & vbCr & _ vbCr & "'" & ClipboardData & "' " & vbCr & vbCr & "Go ahead ?", vbYesNo + vbQuestion, "Officena") = vbNo Then Cancel = True End If End Sub Private Sub Workbook_CellCut(ByVal Target As Range, ByVal ClipboardData As String, ByRef Cancel As Boolean) If MsgBox("You are about to cut the following Range to the clipboard:" & vbCr & _ vbCr & "'" & Target.Address(external:=True) & "' " & vbCr & vbCr & "Go ahead ?", vbYesNo + vbQuestion, "Officena") = vbNo Then Cancel = True End If End Sub

السلام عليكم هدا الكود ينفع اذا اردنا ان يكون ملفنا يتيما أي أن نضمن له ان يكون دائما مفتوحا على انفراد في نسخة منفصلة لبرنامج الاكسيل .. كنت قد كتبت هدا الكود قبل سنين و الأن أدخلت عليه بعض التحسينات المهمة أضف الكود التالي في ThisWorkbook Module : لكي يشتغل الكود ينبغي أولا حفض الملف بعد اضافة الكود ثم اغلاقه ثم اعادة فتحه Option Explicit Private WithEvents oAppEvents As Application Private oWb As Workbook Private Sub Workbook_Open() Dim oNewApp As New Application On Error GoTo errHandler If Workbooks.Count > 1 Then Application.DisplayAlerts = False Me.ChangeFileAccess xlReadOnly oNewApp.Workbooks.Open Me.FullName oNewApp.Visible = True Me.Close False End If Set oAppEvents = Application errHandler: Set oNewApp = Nothing Application.DisplayAlerts = True Application.EnableEvents = True End Sub Private Sub oAppEvents_NewWorkbook(ByVal Wb As Workbook) Dim oNewApp As New Application Wb.Close False oNewApp.Workbooks.Add oNewApp.Visible = True Set oNewApp = Nothing End Sub Private Sub oAppEvents_WorkbookOpen(ByVal Wb As Workbook) If Wb Is Me Then Exit Sub On Error GoTo errHandler Set oWb = Wb With Application .DisplayAlerts = False .EnableEvents = False oWb.ChangeFileAccess xlReadOnly .OnTime Now, Me.CodeName & ".CloseWB" End With errHandler: Application.DisplayAlerts = True Application.EnableEvents = True End Sub Private Sub CloseWB() Dim oNewApp As New Application oNewApp.Workbooks.Open oWb.FullName oNewApp.Visible = True oWb.Close False Set oWb = Nothing Set oNewApp = Nothing End Sub