البحث في الموقع

السلام عليكم من المعروف أن الاكسل يسمح باضافة صورة خلفية لورقة العمل عن طريق Page Layout ==> BackGround لكن ليس من الممكن اضافة صورة خلفية فقط لجزء من الورقة يعني صورة وراء بعض الخلايا فقط .. الكود التالي يسمح لنا بذالك http:// الكود في موديول عادي Option Explicit Private Type POINTAPI x As Long y As Long End Type Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type #If VBA7 Then #If Win64 Then Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr #Else Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr #End If #Else Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long #End If #If VBA7 Then Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) 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 MoveWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal hwnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long Private Declare PtrSafe Function SelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr) As Long Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As LongPtr Private Declare PtrSafe Function CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode As Long) As Long Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, pt As POINTAPI) As Long Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hwnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) 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 IsIconic Lib "user32" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private lRgn1 As LongPtr, lRgn2 As LongPtr Private hwndImage As LongPtr, hwndExcel7 As LongPtr #Else Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long) As Long Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function PtInRect Lib "user32" (lpRect As RECT, pt As POINTAPI) As Long Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hwnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function IsIconic Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private lRgn1 As Long, lRgn2 As Long Private hwndImage As Long, hwndExcel7 As Long #End If Private Const GWL_STYLE = (-16) Private Const WS_CAPTION = &HC00000 Private Const WS_BORDER = &H800000 Private Const WS_DLGFRAME = &H400000 Private Const WS_THICKFRAME = &H40000 Private Const WS_DISABLED = &H8000000 Private Const GWL_EXSTYLE = (-20) Private Const WS_EX_LAYERED = &H80000 Private Const WS_EX_TRANSPARENT = &H20& Private Const WS_EX_DLGMODALFRAME = &H1 Private Const WS_EX_TOPMOST = &H8& Private Const LOGPIXELSX = 88 Private Const LOGPIXELSY = 90 Private Const POINTSPERINCH = 72 Private Const SWP_FRAMECHANGED = &H20 Private Const RGN_AND = 1 Private Const LWA_ALPHA = &H2& Private tTargetRangeRect As RECT Private oTargetRange As Range 'Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long ' Calling Macros .. '-------------------------- Public Sub ShowImage() Call DisplayImage(UserForm1, Sheet1.Range("B8: E20")) End Sub Public Sub HideImage() Call CleanUp(UserForm1) End Sub 'Public Routines .. '------------------- Public Sub DisplayImage(ByVal Img As Object, ByVal TargetRange As Range) KillTimer Application.hwnd, 0 RemoveProp Application.hwnd, "Image" If GetProp(Application.hwnd, "Image") <> 0 Then Exit Sub Set oTargetRange = TargetRange hwndExcel7 = FindWindowEx(FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString), 0, "EXCEL7", vbNullString) tTargetRangeRect = GetRangeRect(oTargetRange) Img.StartUpPosition = 0 hwndImage = FindWindow(vbNullString, Img.Caption) SetProp Application.hwnd, "Image", hwndImage Call SetWindowLong(hwndImage, GWL_STYLE, GetWindowLong(hwndImage, GWL_STYLE) And Not WS_CAPTION) DrawMenuBar hwndImage Call SetWindowLong(hwndImage, GWL_STYLE, GetWindowLong(hwndImage, GWL_STYLE) _ And Not WS_BORDER And Not WS_THICKFRAME And Not WS_DLGFRAME Or WS_DISABLED) With tTargetRangeRect Call SetWindowPos(hwndImage, WS_EX_TOPMOST, .Left, .Top, .Right - .Left, .Bottom - .Top, SWP_FRAMECHANGED) End With Call SetWindowLong(hwndImage, GWL_EXSTYLE, GetWindowLong(hwndImage, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME) SetWindowLong hwndImage, GWL_EXSTYLE, GetWindowLong(hwndImage, GWL_EXSTYLE) Or WS_EX_LAYERED SetWindowLong hwndImage, GWL_EXSTYLE, GetWindowLong(hwndImage, GWL_EXSTYLE) Or WS_EX_TRANSPARENT SetLayeredWindowAttributes hwndImage, 0, 128, LWA_ALPHA Img.Show vbModeless SetTimer Application.hwnd, 0, 1, AddressOf ImagePositionMonitor End Sub Public Sub CleanUp(ByVal Img As Object) KillTimer Application.hwnd, 0 RemoveProp Application.hwnd, "Image" Unload Img End Sub 'Private Routines .. '------------------- Private Sub ImagePositionMonitor() Static l1 As Long, t1 As Long, r1 As Long, b1 As Long, _ l2 As Long, t2 As Long, r2 As Long, b2 As Long Dim tpt1 As POINTAPI, tpt2 As POINTAPI, tCurPos As POINTAPI Dim tVsbRngRect As RECT On Error Resume Next tVsbRngRect = GetRangeRect(ActiveWindow.VisibleRange) tTargetRangeRect = GetRangeRect(oTargetRange) GetCursorPos tCurPos ' If GetAsyncKeyState(vbKeyLButton) <> 0 And PtInRect(tVsbRngRect, tCurPos) <> 0 And _ ' TypeName(ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)) = "Range" And _ ' tTargetRangeRect.Left = l1 Then Exit Sub If GetAsyncKeyState(vbKeyLButton) <> 0 And _ TypeName(ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)) = "Range" And _ tTargetRangeRect.Left = l1 Then Exit Sub If Not ActiveSheet Is oTargetRange.Parent Or IsIconic(Application.hwnd) Then ShowWindow hwndImage, 0 Exit Sub Else ShowWindow hwndImage, 1 End If With tTargetRangeRect MoveWindow hwndImage, .Left, .Top, _ .Right - .Left, _ .Bottom - .Top, True tpt1.x = .Left tpt1.y = .Top tpt2.x = .Right tpt2.y = .Bottom ScreenToClient hwndExcel7, tpt1 ScreenToClient hwndExcel7, tpt2 .Left = tpt1.x .Top = tpt1.y .Right = tpt2.x .Bottom = tpt2.y End With With tVsbRngRect tpt1.x = .Left tpt1.y = .Top tpt2.x = .Right tpt2.y = .Bottom ScreenToClient hwndExcel7, tpt1 ScreenToClient hwndExcel7, tpt2 .Left = tpt1.x .Top = tpt1.y .Right = tpt2.x .Bottom = tpt2.y End With With tTargetRangeRect If .Left <> l1 Or .Top <> t1 Or tVsbRngRect.Left <> l2 Or tVsbRngRect.Top <> t2 Or _ .Right <> r1 Or .Bottom <> b1 Or tVsbRngRect.Right <> r2 Or tVsbRngRect.Bottom <> b2 Then lRgn1 = CreateRectRgn(-tVsbRngRect.Left, -tVsbRngRect.Top, tVsbRngRect.Right, tVsbRngRect.Bottom) lRgn2 = CreateRectRgn(tVsbRngRect.Left - .Left, tVsbRngRect.Top - .Top, _ tVsbRngRect.Right - .Left, tVsbRngRect.Bottom - .Top) Call CombineRgn(lRgn2, lRgn2, lRgn1, RGN_AND) SetWindowRgn hwndImage, lRgn2, True DeleteObject lRgn1 DeleteObject lRgn2 End If End With With tTargetRangeRect l1 = .Left t1 = .Top r1 = .Right b1 = .Bottom End With With tVsbRngRect l2 = .Left t2 = .Top r2 = .Right b2 = .Bottom End With End Sub Private Function GetRangeRect(ByVal rng As Range) As RECT Dim OWnd As Window Set OWnd = rng.Parent.Parent.Windows(1) With rng GetRangeRect.Left = PTtoPX(.Left * OWnd.Zoom / 100, 0) _ + OWnd.PointsToScreenPixelsX(0) GetRangeRect.Top = PTtoPX(.Top * OWnd.Zoom / 100, 1) _ + OWnd.PointsToScreenPixelsY(0) GetRangeRect.Right = PTtoPX(.Width * OWnd.Zoom / 100, 0) _ + GetRangeRect.Left GetRangeRect.Bottom = PTtoPX(.Height * OWnd.Zoom / 100, 1) _ + GetRangeRect.Top End With End Function Private Function PTtoPX _ (Points As Single, bVert As Boolean) As Long PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH End Function Private Function ScreenDPI(bVert As Boolean) As Long Static lDPI(1), lDC If lDPI(0) = 0 Then lDC = GetDC(0) lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX) lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY) lDC = ReleaseDC(0, lDC) End If ScreenDPI = lDPI(Abs(bVert)) End Function بم تجريب الكود على Windows 64Bit Office 2010 64Bit و Windows 7 32Bit Office 2007 ملف للتحميل