جعفر الطريبق

نوفمبر 12, 2015

استاذ مختار

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

شكرا

نوفمبر 12, 2015

السلام عليكم

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

نوفمبر 12, 2015

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

لو توصلت الى نتيجة محترمة سأتشر الكود هنا

نوفمبر 10, 2015

بارك الله فيك أستاذ مختار حسين

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

نوفمبر 8, 2015

عمل جميل يا استاذ وائل أحمد ... بارك الله فيك

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

نوفمبر 7, 2015

السلام عليكم و بارك الله فيكم جميعا على الردود الطيبة

الدالة Hyperlink تتقبل ماكرو في ال (First Argument ) و نتفذها عند تحريك الماوس فوق الخلية و هو حسب علمي أمر غير مقصود و غير موثق من طرف مايكروسوفت .. الكود يستغل هذه الخاصية ..كل ما يقوم به الكود هو تغيير لون الخلية و اظهار الصور المخفية مسبقا بعد تحديد مكانها قرب الخلية

الملف يستعمل أسماء Named Ranges مطابقة لأسماء الصور لاستدعاء الصور المناسبة

استعملت ال GetCursorPos API لجعل عملية اظهار و اخفاء الصور عملية سلسة و سريعة

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

نوفمبر 6, 2015

السلام عليكم

ملف للتحميل : 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

نوفمبر 4, 2015

اخى واستاذنا جعفر

ماشاء الله عليك

كود جميل ويعمل باتقان

بارك الله فيك

تقبل تحياتى

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

نوفمبر 4, 2015

واجهة جميلة

نوفمبر 4, 2015

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

نوفمبر 4, 2015

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

نوفمبر 4, 2015

كذالك و بنفس الطريقة يمكن اضافة يوم الأسبوع بالحروف العربية الى 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 بعض الشيء لكي يظهر كل النص

نوفمبر 4, 2015

السلام عليكم

بعد اذن الأستاذ ياسر , قم بتغيير الدالة 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

نوفمبر 3, 2015

السلام عليكم

لو افترضنا أن التكست بوكس هو 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

أكتوبر 24, 2015

السلام عليكم

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

أكتوبر 24, 2015

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

أكتوبر 20, 2015

السلام عليكم

تفضلوا التسخة 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

أكتوبر 20, 2015

السلام علبكم

ملف للتحميل : 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

أكتوبر 8, 2015

السلام عليكم

ادهب الى محرر الأكواد و اعمل رايت كليك على الفورم و اختر Export File من القائمة و احفظ الملف (UserForm.frm) في محفظة من اختيارك

افتح الملف الثاني و ادهب الى محرر الأكواد و اعمل رايت كليك على ال VBAProject للملف و اختار Import File من القائمة و اختار ملف الفورم الدي حفظته في الخطوة السابقة

لو أردت ازالة الفورم نهائيا من الملف الأول بعد اتمام عملية النقل فاعمل كالتالي:

ادهب الى محرر الأكواد و اعمل رايت كليك على الفورم و اختر Delete UserForm من القائمة

أكتوبر 8, 2015

السلام عليكم

أستادي الفاضل أنس دروبي

السلوك الطبيعي للاكسيل هو أن يفتح جميع الملفات داخل برنامج أكسيل واحد يعني في نفس ال Excel Instance

أما ما يفترض أن يحدث عندما نفتح الملف الدي يحتوي على الكود فهو كالتالي:

السيناريو الاول - عندما يكون هنالك ملف أخر أو أكثر مفتوح مسبقا قبل فتح الملف الدي فيه الكود

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

السيناريو الثاني- عندما ليس هنالك أي ملف أخر مفتوح مسبقا

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

النتيجة المفترضة :

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

استادي أنس دروبي .. هل جربت الكود و أعطى النتيجة المطلوبة ?

أما في ما يخص مسألة كون الاكسيل يفتح الملفات في شكل نوافد منفصلة عن بعضها البعض كما تفضلت فان هد أمر أخر لا صلة له بما نتحدث عنه هنا لأن رغم انفصال نوافد الملفات الا أن الملفات تكون كلها مفتوحة في نفس نسخة الاكسيل أما ما يفعله الكود هو اجبار الملفات أن تكون مفتوحة في نسخ منفصلة لبرامج الاكسيل ... هنالك فرق بين ال Workbook.Windows و الApplication Instances

هنالك شيئ واحد لم انتبه اليه و لم أخده بعين الاعتبار عند كتابة الكود هو في حالة وجود ملف Personal.xls او ملف Addin.xla مفتوح يمكن للكود أن يفشل في تحقيق المطلوب ... لاحقا سأعدل الكود ليأخد هده الحالة في عين الاعتبار

*****************************************************************************************************************

في ما يتعلق بسؤالك عن فتح ملف أخر بينما اليوزرفورم مفعل فهل تقصد أن تفتح الملف الأخر عبر كود في اليوزرفورم أم مادا ... السؤال غير واضح لي يا أستادي الفاضل ... حسب معلوماتي و تجربتي فان وجود يوزرفورم مفعل لا يمنع من فتح ملف أخر بطريقة مباشرة ادا كان الفورم مفعلا بطريقة Modeless أو عن طريق الكود سواء كان الفورم مفعلا بطريقة Modeless أو Modal

أرجو التوضيح اكثر

أكتوبر 8, 2015

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

أقترح الكود البديل التالي

Private Sub Workbook_Open()
    Application.Goto Sheets("Sheet3").Range("H6"), True
End Sub

أكتوبر 7, 2015

السلام عليم

يبدو أنني لم أوفق في شرح وظيفة الكود ... دعني أشرح بطريقة أخرى خطوة خطوة

1- افتح ملفا جديدا و اضف الكود اليه داخل ال ThisWorkbook Module

2- احفظ الملف و اغلقه و اغلق برنامج الاكسيل لو كان الاكسيل لا زال مفتوحا

3- افتح الملف من جديد و اتركه مفتوحا

4- الأن افتح ملفا أخر أيا كان هدا الملف الأخر

النتيجة : الأن لديك ملفان مفتوحان لكن عوض أن يكون الملفان مفتوحان في نسخة واحدة مشتركة للاكسل كما هو معهود ستجد أن كل ملف مفتوح لوحده في نسخة منفصلة للاكسيل خاصة به ... بمعنى أخر ستجد أن لديك في المجموع نسختان منفصلتين للاكسيل و ليس نسخة واحدة .... النسخة الأولى للاكسيل موجود فيها الملف الأول (يعني الملف صاحب الكود) و النسخة الثانية فيها الملف الثاني

لو فتحت ملفا ثالتا سيحدث نفس الشيئ و هكدا

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

أرجو أن يكون الشرح وافيا

أكتوبر 6, 2015

استادي الفاضل ياسر

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

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

أكتوبر 6, 2015

السلام عليكم

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

أضف الكود التالي الى ال 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

أكتوبر 6, 2015

السلام عليكم

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

أضف الكود التالي في 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

تسجيل الدخول

المنتدى

مكتبة الموقع

معرض الصور

المدونات

الوسائط المتعددة

مشاركات المكتوبه بواسطه جعفر الطريبق

Important Information