Visual Basic, .NET, ASP, VBScript
Новости | Примеры | Библиотека кодов | НеЧаВо | VBA | Справочник по VB | Справочник по WinAPI | ActiveX контролы | Статьи по VB | Мастерская разработчика | Форум VBNet | Яndex bar! | Голосование | Полезные программы | Магазин VBNet | Рассылка | Конкурсы | Юмор | Чат | Реклама на VBNet | Автора! | Ссылки | Бета-тестирование | Послать пример на сайт
 

   
   
     

Форум - Общий форум

Страница: 1 | 2 | 3 | 4 |

 

  Вопрос: Windows 7 Vista Aero Glass code Visual Basic 6 Добавлено: 09.10.09 06:20  

Автор вопроса:  Smith | ICQ: adamis@list.ru 
В новом проекте EXE бросьте на форму пару лабелей.

Проект - Форма(Кот)[source]Option Explicit

Private m_ScaleX As Long
Private m_ScaleY As Long
Private m_hdc As Long
Private m_hwnd As Long
Private m_hTheme As Long
Private c_hFont As Long
Private m_hFont As Long
Private 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 DT_VCENTER = &H4
Const DT_TOP = &H0
Const DT_CENTER = &H1
Const DT_SINGLELINE = &H20
Const DT_BOTTOM = &H8
Const DT_RIGHT = &H2
Const DT_NOPREFIX = &H800
Const SPI_GETNONCLIENTMETRICS = 41
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

Private sText As String
Private Glass As Boolean


Private Sub Form_Load()
    Dim lEnabled As Long
    Dim X As Long
    Dim F As String
    Dim mg As MARGINS
    Dim lpFont As LOGFONT
    Dim ncm As NONCLIENTMETRICS

    sText = "Aero Glass фифект"
    m_hdc = hDC
    Glass = Len(Environ$("LOCALAPPDATA")) > 0 'верный признак Vista и Windows 7
    If Glass Then
        With Screen
            m_ScaleX = .TwipsPerPixelX
            m_ScaleY = .TwipsPerPixelY
        End With
        With Me
            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 = 500
            .lfHeight = .lfHeight * 1.2
            m_lFontSize = -.lfHeight
            .lfQuality = CLEARTYPE_QUALITY
        End With
        m_hFont = CreateFontIndirect(lpFont)
        With lpFont
            .lfWeight = 500
            .lfHeight = .lfHeight * 1.3
            m_lFontSize = -.lfHeight
            .lfQuality = CLEARTYPE_QUALITY
            For X = 0 To 8
                .lfFaceName(X) = Asc(Mid$("Wingdings", X + 1, 1))
            Next
            For X = 9 To 31
                .lfFaceName(X) = 0
            Next
        End With
        c_hFont = CreateFontIndirect(lpFont)
        Call DwmIsCompositionEnabled(lEnabled)
        If (lEnabled) Then Call DwmExtendFrameIntoClientArea(m_hwnd, mg)
        Label1.Visible = False
        Label2.Visible = False
    Else
        With Label1
            .Enabled = False
            .Height = 255
            .Width = 780
            .Left = ScaleWidth - 1015
            .Top = ScaleHeight - 300
            .Font.Name = "Wingdings"
            .Font.Size = 13
            .Font.Bold = True
            .Caption = "ю Ь"
            .Visible = True
        End With
        With Label2
            .Alignment = vbCenter
            .Enabled = False
            .Height = 615
            .Width = 2580
            .Left = 480
            .Top = 1200
            .Font.Name = "Tahoma"
            .Font.Size = 12
            .Caption = sText & vbCr & " не работает !!!"
            .Visible = True
        End With
    End If
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Y > 2870 And Y < 3160 Then
        If X > 3000 And X < 3230 Then MsgBox "Go"
        If X > 2460 And X < 2760 Then MsgBox "Check"
    End If
End Sub

Private Sub Form_Paint()
    Dim obj As Long
    Dim hOld As Long
    Dim lpRect As RECT

    If Glass Then
        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
        Call DrawGlassEffect(lpRect)
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If Glass Then
        If m_hTheme Then CloseThemeData (m_hTheme)
        If m_hFont Then DeleteObject (m_hFont)
    End If
End Sub

Private Sub DrawGlassEffect(lpRect As RECT)
    Dim bm As Long
    Dim hOld As Long
    Dim handle As Long
    Dim dib As BITMAPINFO
    Dim dto As DTTOPTS

    handle = CreateCompatibleDC(m_hdc)
    With dib.bmiHeader
        .biSize = 40
        .biWidth = 50 * 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
        .iGlowSize = 10
    End With
    bm = CreateDIBSection(m_hdc, dib, DIB_RGB_COLORS, 0, 0, 0)
    hOld = SelectObject(handle, bm)
    Call SelectObject(handle, m_hFont)
    Call DrawThemeTextEx(m_hTheme, handle, 0, 0, StrConv(sText, vbUnicode), -1, DT_SINGLELINE Or DT_CENTER Or DT_VCENTER Or DT_NOPREFIX, lpRect, dto)
    Call SelectObject(handle, c_hFont)
    Call DrawThemeTextEx(m_hTheme, handle, 0, 0, StrConv("ю Ь ", vbUnicode), -1, DT_SINGLELINE Or DT_RIGHT Or DT_BOTTOM Or DT_NOPREFIX, lpRect, dto)
    Call BitBlt(m_hdc, 0, 0, 50 * m_ScaleX, m_lFontSize * m_ScaleY, handle, 0, 0, vbSrcCopy)
    Call SelectObject(handle, hOld)
    DeleteObject bm
    DeleteDC handle
End Sub[/source]
Пример выдран из рабочей программы, поэтому попрошу не ругаться на кучу лишнего хлама в коде, он может пригодится ...

Ответить

  Ответы Всего ответов: 55  

Номер ответа: 1
Автор ответа:
 maza_____



ICQ: 9968842 

Вопросов: 40
Ответов: 337
  Web-сайт: vkontakte.ru/id25563295 добавляйтесь в друзья))
 Профиль | Цитата | #1 		Добавлено: 09.10.09 14:16
VB.NET:
  1. Dim i As Integer = 1
  2.     Dim Marg As MARGINS
  3.     Public Structure MARGINS
  4.         Dim cxLeftWidth As Integer
  5.         Dim cxRightWidth As Integer
  6.         Dim cyTopHeight As Integer
  7.         Dim cyBottomHeight As Integer
  8.     End Structure
  9.     <DllImport("DwmApi.dll")> _
  10.     Public Shared Function DwmExtendFrameIntoClientArea(ByVal hwnd As IntPtr, ByRef MARGINS As MARGINS) As Integer
  11.     End Function

Ответить

Номер ответа: 2
Автор ответа:
 UnDeAdZak



Вопросов: 80
Ответов: 476
  Профиль | Цитата | #2 Добавлено: 09.10.09 14:31
гм! end function ты написал, но где она стартует?

Ответить

Номер ответа: 3
Автор ответа:
 maza_____



ICQ: 9968842 

Вопросов: 40
Ответов: 337
  Web-сайт: vkontakte.ru/id25563295 добавляйтесь в друзья))
 Профиль | Цитата | #3 		Добавлено: 09.10.09 14:53
  1. Imports System.Runtime.InteropServices
  2. Public NotInheritable Class AboutBox1
  3.     Dim i As Integer = 1
  4.     Dim Marg As MARGINS
  5.     Public Structure MARGINS
  6.         Dim cxLeftWidth As Integer
  7.         Dim cxRightWidth As Integer
  8.         Dim cyTopHeight As Integer
  9.         Dim cyBottomHeight As Integer
  10.     End Structure
  11.     <DllImport("DwmApi.dll")> _
  12.     Public Shared Function DwmExtendFrameIntoClientArea(ByVal hwnd As IntPtr, ByRef MARGINS As MARGINS) As Integer
  13.     End Function
  14.  
  15.     Private Sub AboutBox1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
  16.         If My.Computer.Info.OSVersion.Substring(0, 1) = "6" Then
  17.             Marg.cxLeftWidth = 215
  18.             Marg.cxRightWidth = 10
  19.             Marg.cyTopHeight = 10
  20.             Marg.cyBottomHeight = 40
  21.             DwmExtendFrameIntoClientArea(Me.Handle, Marg)
  22.         End If
  23.     End Sub
  24. End Class

Ответить

Номер ответа: 4
Автор ответа:
 User Unknown



Вечный Юзер!

ICQ: uu@jabber.cz 

Вопросов: 120
Ответов: 3302
  Профиль | Цитата | #4 Добавлено: 09.10.09 15:04
UnDeAdZak пишет:
гм! end function ты написал, но где она стартует?


На десятой строчке, не?:)

Ответить

Номер ответа: 5
Автор ответа:
 VβÐUηìt



Вопросов: 246
Ответов: 3333
  Web-сайт: смекаешь.рф
 Профиль | Цитата | #5 		Добавлено: 09.10.09 17:14
  1. Dim i As Integer = 1
  2.     Dim Marg As MARGINS
  3.     Public Structure MARGINS
  4.         Dim cxLeftWidth As Integer
  5.         Dim cxRightWidth As Integer
  6.         Dim cyTopHeight As Integer
  7.         Dim cyBottomHeight As Integer
  8.     End Structure
  9.     <DllImport("DwmApi.dll")> _
  10.     Public Shared Function DwmExtendFrameIntoClientArea(ByVal hwnd As IntPtr, ByRef MARGINS As MARGINS) As Integer
  11.     End Function

Это другое. Вы здесь парите васю с отступами по бокам, сверху и снизу, а у него код сплошняком покрывает все окно плюс он подрубил васю для работы с текстом с ореолом. Не надо пытаться сделать вид, что, мол, на .NET это будет всего 20 строчек.

PS: Я вот это еще очень хочу в класс обернуть (можно и на дотнете), чтоб вообще было по оццоффски - а-ля для стеклопечати используем Print, для задания стеклянных областей просто используем некую "стеклянную" кисть. Будет вообще супер :) Кстати, а там от SolidBrush можно класс унаследовать и перегрузить все его члены? Ну чтоб действительно стеклокисточку получить?

Ответить

Номер ответа: 6
Автор ответа:
 Smith



ICQ: adamis@list.ru 

Вопросов: 153
Ответов: 3632
  Профиль | Цитата | #6 Добавлено: 09.10.09 18:32
Кстати в моем коде есть лажа, не выставляется размер окна, от этого зависит работа импровизированных кнопочек в нижнем углу.
VВD не буянь, пусть дотнэтчики себя пробуют в программировании АПИ, может чему научатся :-D, есть время небольшой алго переписать?
Winаnd, я в плеере не смотрел, может VBD возьмется, я свой алго знаю и так быстрее въеду, чем ковырять, вникать в чужой код.
UU, я недавно один примерчик Павлу в ящик на митуе кинул, ты не в курсе?
Автор я :), пример того как можно взять 32х32х32 иконку экзешника и как есть назначить её форме, для свисты и семерки актуальное украшение.
Может есть смысл его выложить в Примерах?

Ответить

Номер ответа: 7
Автор ответа:
 Winand



Вопросов: 87
Ответов: 2795
  Web-сайт: winandfx.narod.ru
 Профиль | Цитата | #7 		Добавлено: 09.10.09 19:43
Smith, ну если ты не можешь в банальном маленьком modSpectrum.bas разобрацо, то я уж не знааю) Покури инфу о SetDIBitsToDevice в таком случае.
что за иконка? в смысле примерчик, как 32битовую иконку приделать?

Ответить

Номер ответа: 8
Автор ответа:
 Winand



Вопросов: 87
Ответов: 2795
  Web-сайт: winandfx.narod.ru
 Профиль | Цитата | #8 		Добавлено: 09.10.09 20:28
Не уверен, что узанвать версию винды, да еще таким образом - корректно. Тем более, что Аэро можно отключить, даже если у тебя стоит Win7

Ответить

Номер ответа: 9
Автор ответа:
 Winand



Вопросов: 87
Ответов: 2795
  Web-сайт: winandfx.narod.ru
 Профиль | Цитата | #9 		Добавлено: 09.10.09 21:20
Вот бы еще цвета оставались нормальными. http://imagebin.org/66923 Чтобы можно сделать такого..

Вот минимальный гласс-класс.
  1. Option Explicit
  2. Private m_hdc As Long
  3. Private m_hwnd As Long
  4.  
  5. Private Type MARGINS
  6.   Left As Long
  7.   Right As Long
  8.   Top As Long
  9.   Bottom As Long
  10. End Type
  11.  
  12. Private Declare Function DwmExtendFrameIntoClientArea Lib "dwmapi.dll" (ByVal hWnd As Long, margin As MARGINS) As Long
  13. Private Declare Function DwmIsCompositionEnabled Lib "dwmapi" (ByRef pfEnabled As Long) As Long
  14.  
  15. Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
  16. Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
  17. Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
  18.  
  19. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  20. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  21. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  22.                                                         
  23. Private canGlass As Boolean
  24.  
  25. Public Sub init(ByVal wnd As Long)
  26.     Dim lEnabled As Long
  27.     Dim mg As MARGINS
  28.  
  29.     m_hdc = GetDC(wnd)
  30.     canGlass = Len(Environ$("LOCALAPPDATA")) > 0 'верный признак Vista и Windows 7
  31.     
  32.     If canGlass Then
  33.         m_hwnd = wnd
  34.         
  35.         mg.Left = -1
  36.         mg.Right = -1
  37.         mg.Top = -1
  38.         mg.Bottom = -1
  39.         
  40.         Call DwmIsCompositionEnabled(lEnabled)
  41.         If lEnabled Then _
  42.             Call DwmExtendFrameIntoClientArea(m_hwnd, mg)
  43.     End If
  44. End Sub
  45.  
  46. Public Sub updateGlassEffect()
  47.     Dim obj As Long
  48.     Dim hOld As Long
  49.     Dim lpRect As RECT
  50.  
  51.     If canGlass Then
  52.         obj = CreateSolidBrush(RGB(0, 0, 0))
  53.         hOld = SelectObject(m_hdc, obj)
  54.         GetClientRect m_hwnd, lpRect
  55.         lpRect.Right = lpRect.Right + 30 'Хрень. И лажа. И костыли тупые.
  56.         lpRect.Bottom = lpRect.Bottom + 40 'Видимо clientrect считает без заголовка окна
  57.                                     'а филлрект - с ним, т.ч. гласс не дотягивается до края окна)
  58.                                     'Еще чуть-чуть заходим за край окна, чтобы ресайзинг был красивый
  59.         FillRect m_hdc, lpRect, obj
  60.         SelectObject m_hdc, hOld
  61.         DeleteObject obj
  62.     End If
  63. End Sub

Ответить

Номер ответа: 10
Автор ответа:
 Winand



Вопросов: 87
Ответов: 2795
  Web-сайт: winandfx.narod.ru
 Профиль | Цитата | #10 		Добавлено: 09.10.09 21:46
Ан-нет. Я ошибся минимумом. updateGlassEffect можно выкинуть. Вот только при ресайзе окна, довольно тупо получается

Ответить

Номер ответа: 11
Автор ответа:
 Smith



ICQ: adamis@list.ru 

Вопросов: 153
Ответов: 3632
  Профиль | Цитата | #11 Добавлено: 09.10.09 21:50
Winаnd, а сказал, что немогу разобраться???
Мне просто лень, ну раз ты говоришь, что всё так банально, то гляну конечно, спасибо.

Я не встречал машин с измененными переменными среды, разве что тэмп переназначают в другое место и свои добавляют иногда.
Не уверен в методе, не используй, вобще делай как хочешь, например можно тупо обработать ошибку.

Тыж знаешь вб6 берет максимум 24 битные иконы для форм, а редактор ресурсов берет и того меньше, 8 бит.
Вот и приходится сторонним редактором ресурсов заменять иконки в экзешнике.
Вобщем в хрюнделе хватало заменить икону экзешника, менялась картина в окне Альт+Таб, проводнике и диспетчере задач, тока в углу формы и в панели задач оставалась убогая 8/24 битная.
А в висте и семерке Альт+Таб, диспетчер задач и панель задач показывают тока маленькую страшненькую икону формы.
Вылечить прогу можно элементарно, тремя апишками, семью строчками кода.

Ответить

Номер ответа: 12
Автор ответа:
 Winand



Вопросов: 87
Ответов: 2795
  Web-сайт: winandfx.narod.ru
 Профиль | Цитата | #12 		Добавлено: 09.10.09 23:37
Smith, я в курсе, что можешь разобраться. Создаешь палитру, заполняешь массив цветами палитры, фигачишь на экран через SetDIBitsToDevice
.Переменные среды - не главное. Как-то проверяется досупность аэро? вот здесь что ли DwmIsCompositionEnabled?
.Раскрой тайну Семи Строк Кода)

Ответить

Номер ответа: 13
Автор ответа:
 Smith



ICQ: adamis@list.ru 

Вопросов: 153
Ответов: 3632
  Профиль | Цитата | #13 Добавлено: 10.10.09 00:14
Щас сплю уже, тока завтра, а вообще неплохо былобы еслибы господа админы добавили таки этот мизерный пустяк в Примеры.

Ответить

Номер ответа: 14
Автор ответа:
 Smith



ICQ: adamis@list.ru 

Вопросов: 153
Ответов: 3632
  Профиль | Цитата | #14 Добавлено: 10.10.09 19:03
  1. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  2. Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
  3. Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
  4.  
  5.     Dim Icon32x32x32 As Long
  6.     Icon32x32x32 = ExtractIcon(App.hInstance, App.Path & "\" & App.EXEName & ".exe", 0)
  7.     Form1.Icon = Nothing 'эта строчка лишняя
  8.     SendMessage hWnd, WM_SETICON, ICON_BIG, ByVal Icon32x32x32
  9.     DestroyIcon Icon32x32x32

Ответить

Номер ответа: 15
Автор ответа:
 Winand



Вопросов: 87
Ответов: 2795
  Web-сайт: winandfx.narod.ru
 Профиль | Цитата | #15 		Добавлено: 10.10.09 22:44
Smith, гружу 32х32(32) из ico-файла. Если закомментить Form1.Icon = Nothing, то ничего не меняется вообще, а если оставить, то ощущение, что оно резайзится до 16х16, а потом попадает в панель задач и растягивается обратно

Ответить

Страница: 1 | 2 | 3 | 4 |

Поиск по форуму



© Copyright 2002-2011 VBNet.RU | Пишите нам