فرم شیشه ای (Aero Glass)

[IamOverlord]

سلام دوستان!
بالاخره فهمیدم چه طوری می شه فرممون رو شیشه ای (Aero Glass) کنیم.

[shahabbasic]

اون خط وسط فرم چیه؟

[IamOverlord]

برای حذف اون خط :

Private Sub cmdAeroEffect_Click(ByVal Button As Integer)
Dim GRect As tRect
Dim lngReturn As Long

' Look Here:
GRect.m_Buttom = -1
GRect.m_Left = -1
GRect.m_Right = -1
GRect.m_Top = -1

Me.BackColor = vbBlack

lngReturn = ApplyGlass(Me.hwnd, GRect)

'lblReturn.Caption = "Return: " & lngReturn
End Sub

[shahabbasic]

ولی بازم حجمش زیاده صرف نمیکنه بخواییم استفاده کنیم

[IamOverlord]

نه اصل کاریه، حجمش کمه:

' here is the code.
' a form with a command button and this code
Option Explicit

Private Const LWA_COLORKEY As Long = &H1
Private Const GWL_EXSTYLE As Long = (-20)
Private Const WS_EX_LAYERED As Long = &H80000
Private Const WS_EX_TRANSPARENT As Long = &H20&
Private Const LWA_ALPHA As Long = &H2&

Private Type tRect
m_Left As Long
m_Right As Long
m_Top As Long
m_Buttom As Long
End Type

Private Declare Function apiApplyGlass Lib "dwmapi.dll" Alias _
"DwmExtendFrameIntoClientArea" (ByVal hWnd As Long, rect As tRect) As _
Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As _
Long

Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd _
As _
Long, ByVal crey As Byte, ByVal bAlpha As Byte, ByVal dwflags As Long) _
As Long

Public Sub ApplyTransparency()
Dim lOldStyle As Long

lOldStyle = GetWindowLong(hWnd, GWL_EXSTYLE)
SetWindowLong hWnd, GWL_EXSTYLE, lOldStyle Or WS_EX_LAYERED
SetLayeredWindowAttributes Me.hWnd, 0, 0, LWA_COLORKEY
End Sub

Private Sub ApplyAero()
Dim GRect As tRect
Dim lngReturn As Long

GRect.m_Buttom = -1
GRect.m_Left = -1
GRect.m_Right = -1
GRect.m_Top = -1

lngReturn = apiApplyGlass(Me.hWnd, GRect)
End Sub

Private Sub Command1_Click()
Me.BackColor = vbBlack
Call ApplyTransparency
Call ApplyAero
End Sub

[سید حمید حق پرست]

اینم سورس بدون اون خط

عکس :

81581

[shahabbasic]

در ویندوز اکس پی هم جواب میده؟

[IamOverlord]

اگر به متغیرهای
GRect.m_Buttom
GRect.m_Left
GRect.m_Right
GRect.m_Top
مقدار 1- رو نسبت بدید بدون خط می شه.

[IamOverlord]

نه. اگه توجه کرده باشی، مرورگر Google Chrome در Windows XP ظاهر گرافیکی اش رو عوض می کنه و از ظاهر Aero استفاده نمی کنه، چون WDM API از Windows Vista به بعد اضافه شد.

[shahabbasic]

ولی بازم یک مشکلی داره اونم اینکه وقتی فرم رو بیاری روی دسکتاپ میشه از پشتش درگ کنی

[IamOverlord]

می شه خیلی دستکاریش کرد و فرم های جالبی درست کرد. هر کی نمونه ی خوبی که به نظرش می رسه این جا بذاره.

[IamOverlord]

ولی بازم یک مشکلی داره اونم اینکه وقتی فرم رو بیاری روی دسکتاپ میشه از پشتش درگ کنی

منظورتون چیه؟ :متفکر:

[shahabbasic]

میشه از پشتش صفحه دسکتاپ رو درگ کنی انگار هیچ فرمی وجود نداره

[IamOverlord]

آها، فکر می کنم این به خاطر اینه که حالت Aero غیر فعال هستش،
یا شایدم روی Windows Vista و به بعد اجرا نمی کنی... :متفکر:
وگرنه شکل Form ات باید مثل همونی شده باشه که تو تصویر می بینی، بدون Drag & Drop از پشتش و ... .

[mahmood744]

این هم یک فرم ویستا بدون هیچ کامپونت

81690

ساده و زیبا

[shahabbasic]

آها، فکر می کنم این به خاطر اینه که حالت Aero غیر فعال هستش،
یا شایدم روی Windows Vista و به بعد اجرا نمی کنی... :متفکر:
وگرنه شکل Form ات باید مثل همونی شده باشه که تو تصویر می بینی، بدون Drag & Drop از پشتش و ... .
نه در ویندوز 7 اجرا کردم
منظورم اینه که اگر توی همین عکسی که گذاشتی مثل همین باشه ماوس رو بکش روی فرم میبینی که آیکن های روی دسکتاپت رو انتخاب میکنه

[Veteran]

نمیشه توی xp استفاده کرد.
برای این مشکل راه حلی دارید ؟

[IamOverlord]

نمیشه توی xp استفاده کرد.
برای این مشکل راه حلی دارید ؟

تا جایی که می دونم نه. Microsoft این کارو برامون می کنه نه ما ... و این کار از Windows Vista به بعد انجام می شه.

[IamOverlord]

نه در ویندوز 7 اجرا کردم
منظورم اینه که اگر توی همین عکسی که گذاشتی مثل همین باشه ماوس رو بکش روی فرم میبینی که آیکن های روی دسکتاپت رو انتخاب میکنه

نمی دونم راستش... واسه من این مشکل پیش نمی آد.

[shahmohammadi]

سلام.

تا جایی که می دونم نه. Microsoft این کارو برامون می کنه نه ما ... و این کار از Windows Vista به بعد انجام می شه. من زیاد تخصص تو این جور کارا ندارم ولی برای ویندوز xp با سی شارپ این کارو می کردم. یادم نیست چه جوری ولی فرم یه ویژگی داشت که با دادن یه عدد از 0 تا 100 می شد این کارو کرد. حالا اگه با سی شارپ می شه حتما اینجا هم میشه.

[IamOverlord]

احتمالا اونی که شما می گید Opcaity فرم هست که با VB6 هم می شه اون کارو کرد. ولی مثل این حالت Aero Glass در نمی آد.

[meys34]

جسارته ولی میشه برای این هم کاری کرد؟

http://www.codeproject.com/KB/vista/AeroGlassLegacyWindowsApp/autoaerougly.png

سایت: C/C++‎
http://www.codeproject.com/Articles/18910/Adding-or-Retrofitting-Aero-Glass-into-Legacy-Wind

[shahmohammadi]

احتمالا اونی که شما می گید Opcaity فرم هست که با VB6 هم می شه اون کارو کرد. ولی مثل این حالت Aero Glass در نمی آد.
درسته همین بود. فقط فرق این دوتا رو من نمی دونم. اگه دوستان اینو هم برای من بگند خوشحال می شم.

[IamOverlord]

ویژگی Opacity فقط میزان دیده شدن یا نشدن محتویات پشت Form رو مشخص می کنه، اون هم برای تمام Pixel های Form به یک اندازه بدون ویژگی تار شدن و سایه انداختن و ... .

[IamOverlord]

جسارته ولی میشه برای این هم کاری کرد؟

http://www.codeproject.com/KB/vista/AeroGlassLegacyWindowsApp/autoaerougly.png

سایت: C/C++‎‎‎
http://www.codeproject.com/Articles/18910/Adding-or-Retrofitting-Aero-Glass-into-Legacy-Wind

می شه، در زبان های دیگه راه حل این مشکل رو گفتن. اما در VB6 چی؟! :متفکر:
فعلا روشی که می شناسم (البته مشکل کامل حل نمی شه :افسرده:) اینه که قبل از Aero Glass کردن Form این Function رو استفاده کنی که در صفحه ی اول تاپیک مثالشو گذاشتم:
Public Sub ApplyTransparency()
Dim lOldStyle As Long

lOldStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
SetWindowLong hwnd, GWL_EXSTYLE, lOldStyle Or WS_EX_LAYERED
SetLayeredWindowAttributes Me.hwnd, 0, 0, LWA_COLORKEY
End Sub

[IamOverlord]

این نمونه رو برای گذاشتن یه متن که Glow Effect داره امتحان کنید:

1. این کد رو برای Form بنویسید:

Private Sub Form_Load()
' init the Glass and some font stuff
Inicializa Me
End Sub

Private Sub Form_Paint()
' EscribeTexto is like WriteText.. and with X and Y
EscribeTexto "Prueba de Texto", 50, 50
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
' this is just to move the Form
ReleaseCapture
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
End Sub

2. این کد رو داخل یه Module:

Option Explicit

Private m_ScaleX As Long
Private m_ScaleY As Long
Private m_hdc As Long
Private m_hwnd As Long

Dim m_hTheme As Long
Dim m_hFont As Long
Dim m_lFontSize As Long

Private Type MARGINS
Left As Long
Right As Long
Top As Long
Bottom As Long
End Type

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type POINTAPI
X As Long
Y 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
biClrUsed As Long
biClrImportant As Long
End Type

Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type

Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type

Private Type DTTOPTS
dwSize As Long
dwFlags As Long
crText As Long
crBorder As Long
crShadow As Long
eTextShadowType As Long
ptShadowOffset As POINTAPI
iBorderSize As Long
iFontPropId As Long
iColorPropId As Long
iStateId As Long
fApplyOverlay As Long
iGlowSize As Long
End Type

Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(31) As Byte
End Type

Private Type NONCLIENTMETRICS
cbSize As Long
iBorderWidth As Long
iScrollWidth As Long
iScrollHeight As Long
iCaptionWidth As Long
iCaptionHeight As Long
lfCaptionFont As LOGFONT
iSMCaptionWidth As Long
iSMCaptionHeight As Long
lfSMCaptionFont As LOGFONT
iMenuWidth As Long
iMenuHeight As Long
lfMenuFont As LOGFONT
lfStatusFont As LOGFONT
lfMessageFont As LOGFONT
End Type

Const DIB_RGB_COLORS = 0
Const BI_RGB = 0
Const DTT_GLOWSIZE = 2048
Const DTT_COMPOSITED = 8192
Const SRCCOPY As Long = &HCC0020
Const DT_SINGLELINE = &H20
Const DT_CENTER = &H1
Const DT_VCENTER = &H4
Const DT_NOPREFIX = &H800
Const SPI_GETNONCLIENTMETRICS = 41
Const DEFAULT_QUALITY = 0
Const NONANTIALIASED_QUALITY = 3
Const ANTIALIASED_QUALITY = 4
Const CLEARTYPE_QUALITY = 5

Private Declare Function DwmExtendFrameIntoClientArea Lib "dwmapi.dll" (ByVal hwnd As Long, margin As MARGINS) As Long
Private Declare Function DwmIsCompositionEnabled Lib "dwmapi" (ByRef pfEnabled As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush 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 SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As NONCLIENTMETRICS, ByVal fuWinIni As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, ByRef pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (ByRef lpLogFont As LOGFONT) As Long
Private Declare Function OpenThemeData Lib "uxtheme" (ByVal hwnd As Long, ByVal pszClassList As String) As Long
Private Declare Function CloseThemeData Lib "uxtheme" (ByVal hTheme As Long) As Long
Private Declare Function DrawThemeTextEx Lib "uxtheme" (ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, ByVal iStateId As Long, ByVal pszText As String, ByVal iCharCount As Long, ByVal dwFlags As Long, pRect As RECT, pOptions As DTTOPTS) As Long

' --------------------------
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As Integer) As Integer

Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2

Public Sub Inicializa(formulario As Form)

Dim enabled As Long
Dim X As Long
Dim mg As MARGINS
Dim lpFont As LOGFONT
Dim ncm As NONCLIENTMETRICS

With Screen
m_ScaleX = .TwipsPerPixelX
m_ScaleY = .TwipsPerPixelY
End With

With formulario
m_hdc = .hdc
m_hwnd = .hwnd
m_hTheme = OpenThemeData(.hwnd, StrConv("Window", vbUnicode))
End With

With mg
.Left = -1
.Right = -1
.Top = -1
.Bottom = -1
End With

With ncm
.cbSize = Len(ncm)
Call SystemParametersInfo(SPI_GETNONCLIENTMETRICS, Len(ncm), ncm, 0)
lpFont = .lfMessageFont
End With

With lpFont
.lfWeight = 700
' Tamaño de la letra
' font size
.lfHeight = .lfHeight * 1.5
m_lFontSize = -.lfHeight
.lfQuality = CLEARTYPE_QUALITY
End With

m_hFont = CreateFontIndirect(lpFont)

Call DwmIsCompositionEnabled(enabled)

If (enabled) Then
Call DwmExtendFrameIntoClientArea(m_hwnd, mg)
End If

End Sub

Public Sub EscribeTexto(texto As String, X As Long, Y As Long)

Dim obj As Long
Dim hOld As Long
Dim lpRect As RECT

obj = CreateSolidBrush(RGB(0, 0, 0))
hOld = SelectObject(m_hdc, obj)
GetClientRect m_hwnd, lpRect
FillRect m_hdc, lpRect, obj
SelectObject m_hdc, hOld
DeleteObject obj

' -------------------------

Dim bm As Long
Dim handle As Long
Dim dib As BITMAPINFO
Dim dto As DTTOPTS

handle = CreateCompatibleDC(m_hdc)

With dib.bmiHeader
.biSize = 40
.biWidth = 40 * m_ScaleX
.biHeight = -m_lFontSize * m_ScaleY
.biPlanes = 1
.biBitCount = 32
.biCompression = BI_RGB
End With

With dto
.dwSize = Len(dto)
.dwFlags = DTT_GLOWSIZE Or DTT_COMPOSITED
' Tamaño del glow (la cosa alrededor del texto)
' glow size
.iGlowSize = 7
End With

bm = CreateDIBSection(m_hdc, dib, DIB_RGB_COLORS, 0, 0, 0)
hOld = SelectObject(handle, bm)

Call SelectObject(handle, m_hFont)

lpRect.Left = X
lpRect.Top = Y

Call DrawThemeTextEx(m_hTheme, handle, 0, 0, StrConv(texto, vbUnicode), -1, DT_SINGLELINE Or DT_NOPREFIX, lpRect, dto)

Call BitBlt(m_hdc, 0, 0, 30 * m_ScaleX, m_lFontSize * m_ScaleY, handle, 0, 0, SRCCOPY)

Call SelectObject(handle, hOld)

DeleteObject bm

DeleteDC handle

End Sub

[program2vb]

سلام به همگی دوستان عزیز من فک کنم فهمیدم مشکل کجاست .... داخل اکتیو ایکس این پروژه از API معکوس استفاده شده که نمیزاره گلس باشه برا همین فقط اون ابزار رو وقتی استفاده میکنیم گلس نمیشه و بقیه ابزار همه گلس میشن .... ما باید یه فریم ( قالب ) طراحی کنیم که ابزار داخل اون قرار بگیرن ... و خاصیت گلس رو اونا اثر نکنه

من روش کار میکنم تا جایی که بتونم

موفق و پیروز باشید .... یا علی

[shshsho]

http://barnamenevis.org/images/icons/icon9.png button glass

سلام دوستان اگه میشه برای من آموزش ساخت ابزارهای زیبا برای vb یا #c بزارین یا اگه فایل آماده دارین به همراه سورس کد یا بصورت dll در اختیارم بزاره ممنون میشم:قلب: