اذهب الي المحتوي
أوفيسنا

هل يمكن جعل الفورم شفاف (( والازرار والليبيلات ظاهرة تماما ))

سما محمد

بواسطه سما محمد
في منتدى الاكسيل Excel

 مشاركة
إذهب إلى أفضل إجابة Solved by حمادة عمر,

الردود الموصى بها

سما محمد

سما محمد

قام بنشر
قام بنشر

في الملف المرفق زر لا ظهار فورم

وبه اكواد لاخفاء وجعل هذا الفورم شفاف ولكني اريد اقصي درجات الشفاقية لهذا الفورم ولكن اريد

اقصي درجات الظهور للكائنات الموجود بالفورم مثل الازرار والليبيلات

 شكرا مقدما لكم

في انتظار الحل

 

 فورم شفاف.rar

رابط هذا التعليق
شارك
سما محمد

سما محمد

قام بنشر
  • الكاتب
قام بنشر

للرفع

ومعذرة اريد اخباري في حالة عدم وجود حل لهذا الموضوع !!!!!! 

ولكني لا اعتقد ذلك ..... ما رأيته هنا في هذا المنتدي الكبير باساتذته  يجعلني بالفعل .... لا اغتقد ذلك

شكرا مقدما لكم

رابط هذا التعليق
شارك
  • أفضل إجابة
حمادة عمر

حمادة عمر

قام بنشر
  • أفضل إجابة
قام بنشر

السلام عليكم

الاخت الفاضلة المهندسة / سما محمد

 

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

واليكي اختي الكريمة الحل في المرفق وهو كود للقدير الرائع / جعفر طرباق  ... جزاه الله خيرا

يقوم بعمل ما تريديه بالضبط وتم تنفيذه علي ملفك

ومرفق ملفك ... وملف للاستاذ / جعفر به الاكواد واليكم الكود ايضا

جزاكي الله خيرا

 

فورم شفاف+.rar

 

TransparentForm.rar

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 BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biRUsed As Long
    biRImportant As Long
End Type
 
Private Type BITMAPINFO_NoColors
    bmiHeader As BITMAPINFOHEADER
End Type
 
Private Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type
 
Private Type MemoryBitmap
    hdc As Long
    hBM As Long
    oldhDC As Long
    wid As Long
    hgt As Long
    bitmap_info As BITMAPINFO_NoColors
End Type
 
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, pBitmapInfo As BITMAPINFO_NoColors, _
ByVal un As Long, ByVal lplpVoid As Long, _
ByVal handle As Long, ByVal dw As Long) _
As Long
 
Private Declare Function GetDIBits Lib "gdi32" _
(ByVal aHDC As Long, ByVal hBitmap As Long, ByVal _
nStartScan As Long, ByVal nNumScans As Long, _
lpBits As Any, lpBI As BITMAPINFO_NoColors, _
ByVal wUsage As Long) _
As Long

Private Declare Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function GetWindow Lib "user32.dll" _
(ByVal hwnd As Long, ByVal wCmd As Long) As Long

Private Declare Function ClientToScreen Lib "user32.dll" _
(ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long

Private Declare Function GetDC Lib "user32.dll" _
(ByVal hwnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32.dll" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Declare Function GetClientRect Lib "user32.dll" _
(ByVal hwnd As Long, ByRef lpRect As RECT) As Long

Private Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, _
ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32.dll" _
(ByVal hdc As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal nWidth As Long, _
ByVal nHeight As Long) As Long

Private Declare Function DeleteObject Lib "gdi32.dll" _
(ByVal hObject As Long) As Long

Private Declare Function SelectObject Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long

Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Declare Function PrintWindow Lib "user32" _
(ByVal hwnd As Long, ByVal hdcBlt As Long, _
ByVal nFlags As Long) As Long

Private Const PICTYPE_BITMAP = 1
Private Const DIB_RGB_COLORS = 0&
Private Const BI_RGB = 0&
Private Const SRCCOPY = &HCC0020
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const SM_CYBORDER = 6
Private Const SM_CYDLGFRAME = 8

Private WithEvents wb As Workbook



Private Sub UserForm_Initialize()

    Set wb = ThisWorkbook
    Call Paint_UserForm

End Sub

Private Sub UserForm_Layout()

    Call Paint_UserForm

End Sub

Private Sub wb_SheetSelectionChange _
(ByVal Sh As Object, ByVal Target As Range)

    Call Paint_UserForm
    
End Sub

Private Sub Paint_UserForm()

    Dim tRect As RECT
    Dim tpt As POINTAPI
    Dim memory_bitmap As MemoryBitmap
    Dim frmDc As Long
    Dim memDc As Long
    Dim scrDc As Long
    Dim oldDc As Long
    Dim tempBmp As Long
    Dim frmHwnd As Long
    Dim frmClientWid As Long
    Dim frmClientHgt As Long
    Dim scrWid As Long
    Dim scrHgt As Long
    Dim X As Long
    Dim Y As Long
    
    
    frmHwnd = FindWindow(vbNullString, Me.Caption)
    frmDc = GetDC(frmHwnd)
    GetClientRect frmHwnd, tRect
    With tRect
        frmClientWid = .Right - .Left
        frmClientHgt = .Bottom - .Top
    End With
    scrWid = GetSystemMetrics(SM_CXSCREEN)
    scrHgt = GetSystemMetrics(SM_CYSCREEN)
    scrDc = GetDC(0)
    memDc = CreateCompatibleDC(scrDc)
    tempBmp = CreateCompatibleBitmap(scrDc, scrWid, scrHgt)
    oldDc = SelectObject(memDc, tempBmp)
    PrintWindow Application.hwnd, memDc, 1
    memory_bitmap = _
    MakeMemoryBitmap(memDc, frmClientWid, frmClientHgt)
    Call ClientToScreen(frmHwnd, tpt)
    X = tpt.X
    Y = tpt.Y
    BitBlt memory_bitmap.hdc, 0, 0, frmClientWid, frmClientHgt, _
    memDc, X + 8, Y + GetSystemMetrics(SM_CYDLGFRAME) + _
    GetSystemMetrics(SM_CYBORDER), SRCCOPY
    SaveMemoryBitmap memory_bitmap, Environ("Temp") & "\temp.bmp"
    Set Me.Picture = LoadPicture(Environ("Temp") & "\temp.bmp")
    ReleaseDC 0, scrDc
    ReleaseDC frmHwnd, frmDc
    SelectObject memDc, oldDc
    DeleteObject tempBmp
    DeleteObject memDc
    SelectObject memory_bitmap.hdc, memory_bitmap.oldhDC
    DeleteObject memory_bitmap.hBM
    DeleteDC memory_bitmap.hdc

End Sub

Private Function MakeMemoryBitmap _
(memDc As Long, wid As Long, hgt As Long) As MemoryBitmap
 
    Dim result As MemoryBitmap
    Dim bytes_per_scanLine As Long
    Dim pad_per_scanLine As Long
 
    result.hdc = CreateCompatibleDC(memDc)
    With result.bitmap_info.bmiHeader
        .biBitCount = 32
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(result.bitmap_info.bmiHeader)
        .biWidth = wid
        .biHeight = hgt
        bytes_per_scanLine = ((((.biWidth * .biBitCount) + _
        31) \ 32) * 4)
        pad_per_scanLine = bytes_per_scanLine - (((.biWidth _
        * .biBitCount) + 7) \ 8)
        .biSizeImage = bytes_per_scanLine * Abs(.biHeight)
    End With
    result.hBM = CreateDIBSection( _
    result.hdc, result.bitmap_info, _
    DIB_RGB_COLORS, ByVal 0&, _
    ByVal 0&, ByVal 0&)
    result.oldhDC = SelectObject(result.hdc, result.hBM)
    result.wid = wid
    result.hgt = hgt
    MakeMemoryBitmap = result
 
End Function

Private Sub SaveMemoryBitmap( _
memory_bitmap As MemoryBitmap, _
ByVal file_name As String _
)
 
    Dim bitmap_file_header As BITMAPFILEHEADER
    Dim fnum As Integer
    Dim pixels() As Byte
 
    With bitmap_file_header
        .bfType = &H4D42
        .bfOffBits = Len(bitmap_file_header) + _
        Len(memory_bitmap.bitmap_info.bmiHeader)
        .bfSize = .bfOffBits + _
        memory_bitmap.bitmap_info.bmiHeader.biSizeImage
    End With
    fnum = FreeFile
    Open file_name For Binary As fnum
        Put #fnum, , bitmap_file_header
        Put #fnum, , memory_bitmap.bitmap_info
        ReDim pixels(1 To 4, _
        1 To memory_bitmap.wid, _
        1 To memory_bitmap.hgt)
        GetDIBits memory_bitmap.hdc, memory_bitmap.hBM, _
        0, memory_bitmap.hgt, pixels(1, 1, 1), _
        memory_bitmap.bitmap_info, DIB_RGB_COLORS
        Put #fnum, , pixels
    Close fnum
 
End Sub

 

  • Like 2
رابط هذا التعليق
شارك
حمادة عمر

حمادة عمر

قام بنشر
قام بنشر

السلام عليكم

الاخت الفاضلة / سما محمد

 

بارك الله فيك اختي الكريمة

ولكن الشكر الواجب للقدير / جعفر طرباق

رابط هذا التعليق
شارك
حمادة عمر

حمادة عمر

قام بنشر
قام بنشر

السلام عليكم

الاستاذ / مجدى يونس

 

بارك الله فيك

فعلا رابط رااائع للاستاذ / الحسامي

جزاك الله خيرا

رابط هذا التعليق
شارك
حمادة عمر

حمادة عمر

قام بنشر
قام بنشر

السلام عليكم

الاستاذ العزيز / مجدى يونس

 

الحمد لله اننني انضممت لهذا المنتدي العملاق

لاتعرف علي اشخاص مثلك استاذنا واخانا العزيز

بجد انت شخص راائع

وبلغ سلامي الي بورسعيد باكملها

جزاك الله خيرا

رابط هذا التعليق
شارك
  • 5 months later...

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept