S
spielmann
Hello
I want to change the scrollbar size of windows, How can I do that with
vb.net
I have find this in VB6 but how can we convert simply this code.
thx
VB6 sample
----------------------------------------------------
'SystemMetrics.csl file
Option Explicit
'Use Font.cls
Option Base 0 'Array begin from 0 to n
Private Const SM_CYCAPTION = 4
Private Const SM_CYMENU = 15
Private Const SM_CYSMCAPTION = 51
Private Const SM_CXDLGFRAME = 7
Private Const SM_CYDLGFRAME = 8
Private Const SM_CXFIXEDFRAME = SM_CXDLGFRAME
Private Const SM_CYFIXEDFRAME = SM_CYDLGFRAME
Const LF_FACESIZE = 32
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(0 To LF_FACESIZE - 1) As Byte
End Type
' SystemParametersInfo flags
Private Const SPIF_UPDATEINIFILE = &H1
Private Const SPIF_SENDWININICHANGE = &H2
' This is a made-up constant.
Private Const SPIF_TELLALL = SPIF_UPDATEINIFILE Or
SPIF_SENDWININICHANGE
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Const SPI_SETNONCLIENTMETRICS = 42
Private Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
Private Declare Function GetDeviceCaps _
Lib "gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function CreateIC _
Lib "gdi32" Alias "CreateICA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function DeleteDC _
Lib "gdi32" _
(ByVal hDC As Long) As Long
Private Declare Function SystemParametersInfo _
Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, ByVal uParam As Long, _
lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function GetSystemMetrics _
Lib "user32" _
(ByVal nIndex As Long) As Long
' NONCLIENTMETRICS Information
Private Type typNonClientMetrics
cbSize As Long
lngBorderWidth As Long
lngScrollWidth As Long
lngScrollHeight As Long
lngCaptionWidth As Long
lngCaptionHeight As Long
lfCaptionFont As LogFont
lngSMCaptionWidth As Long
lngSMCaptionHeight As Long
lfSMCaptionFont As LogFont
lngMenuWidth As Long
lngMenuHeight As Long
lfMenuFont As LogFont
lfStatusFont As LogFont
lfMessageFont As LogFont
End Type
Private ncm As typNonClientMetrics
Private oCaptionFont As Font
Private oSMCaptionFont As Font
Private oMenuFont As Font
Private oStatusFont As Font
Private oMessageFont As Font
Private Function dhTrimNull(strValue As String) As String
On Error GoTo errHandler
Dim intPos As Integer
intPos = InStr(strValue, vbNullChar)
Select Case intPos
Case 0
dhTrimNull = strValue
Case 1
dhTrimNull = vbNullString
Case Else
dhTrimNull = Left$(strValue, intPos - 1)
End Select
Exit Function
errHandler:
ErrorIn "SystemMetrics.dhTrimNull(strValue)", strValue
End Function
Private Sub Class_Initialize()
On Error GoTo errHandler
Dim lngLen As Long
lngLen = Len(ncm)
ncm.cbSize = lngLen
Call SystemParametersInfo(SPI_GETNONCLIENTMETRICS, _
lngLen, ncm, 0)
Set oCaptionFont = New Font
Set oSMCaptionFont = New Font
Set oMenuFont = New Font
Set oStatusFont = New Font
Set oMessageFont = New Font
Call SetFontInfo(ncm.lfCaptionFont, oCaptionFont)
Call SetFontInfo(ncm.lfMenuFont, oMenuFont)
Call SetFontInfo(ncm.lfMessageFont, oMessageFont)
Call SetFontInfo(ncm.lfSMCaptionFont, oSMCaptionFont)
Call SetFontInfo(ncm.lfStatusFont, oStatusFont)
Exit Sub
errHandler:
ErrorIn "SystemMetrics.Class_Initialize", , EA_NORERAISE
ErrSaveToFile
End Sub
Public Property Get BorderWidth() As Long
On Error GoTo errHandler
' Set or retrieve standard window borderwidth.
BorderWidth = ncm.lngBorderWidth
Exit Property
errHandler:
ErrorIn "SystemMetrics.BorderWidth"
End Property
Public Property Let BorderWidth(Value As Long)
On Error GoTo errHandler
' Set or retrieve standard window borderwidth.
ncm.lngBorderWidth = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.BorderWidth(Value)", Value
End Property
Public Property Get ScrollWidth() As Long
On Error GoTo errHandler
' Set or retrieve standard vertical scrollbar width.
ScrollWidth = ncm.lngScrollWidth
Exit Property
errHandler:
ErrorIn "SystemMetrics.ScrollWidth"
End Property
Public Property Let ScrollWidth(Value As Long)
On Error GoTo errHandler
' Set or retrieve standard vertical scrollbar width.
ncm.lngScrollWidth = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.ScrollWidth(Value)", Value
End Property
Public Property Get ScrollHeight() As Long
On Error GoTo errHandler
' Set or retrieve standard horizontal scrollbar height.
ScrollHeight = ncm.lngScrollHeight
Exit Property
errHandler:
ErrorIn "SystemMetrics.ScrollHeight"
End Property
Public Property Let ScrollHeight(Value As Long)
On Error GoTo errHandler
' Set or retrieve standard horizontal scrollbar height.
ncm.lngScrollHeight = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.ScrollHeight(Value)", Value
End Property
Public Property Get CaptionWidth() As Long
On Error GoTo errHandler
' Set or retrieve width of caption bar buttons.
CaptionWidth = ncm.lngCaptionWidth
Exit Property
errHandler:
ErrorIn "SystemMetrics.CaptionWidth"
End Property
Public Property Let CaptionWidth(Value As Long)
On Error GoTo errHandler
' Set or retrieve width of caption bar buttons.
ncm.lngCaptionWidth = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.CaptionWidth(Value)", Value
End Property
Public Property Get CaptionHeight() As Long
On Error GoTo errHandler
' Set or retrieve height of caption bar buttons.
CaptionHeight = ncm.lngCaptionHeight
Exit Property
errHandler:
ErrorIn "SystemMetrics.CaptionHeight"
End Property
Public Property Let CaptionHeight(Value As Long)
On Error GoTo errHandler
' Set or retrieve height of caption bar buttons.
ncm.lngCaptionHeight = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.CaptionHeight(Value)", Value
End Property
Public Property Get CaptionFont() As Font
On Error GoTo errHandler
' Retrieve caption bar font object.
Set CaptionFont = oCaptionFont
Exit Property
errHandler:
ErrorIn "SystemMetrics.CaptionFont"
End Property
Public Property Get SmallCaptionButtonWidth() As Long
On Error GoTo errHandler
' Set or retrieve width of small caption bar buttons.
SmallCaptionButtonWidth = ncm.lngSMCaptionWidth
Exit Property
errHandler:
ErrorIn "SystemMetrics.SmallCaptionButtonWidth"
End Property
Public Property Let SmallCaptionButtonWidth(Value As Long)
On Error GoTo errHandler
' Set or retrieve width of small caption bar buttons.
ncm.lngSMCaptionWidth = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.SmallCaptionButtonWidth(Value)", Value
End Property
Public Property Get SmallCaptionButtonHeight() As Long
On Error GoTo errHandler
' Set or retrieve height of small caption bar buttons.
SmallCaptionButtonHeight = ncm.lngSMCaptionHeight
Exit Property
errHandler:
ErrorIn "SystemMetrics.SmallCaptionButtonHeight"
End Property
Public Property Let SmallCaptionButtonHeight(Value As Long)
On Error GoTo errHandler
' Set or retrieve height of small caption bar buttons.
ncm.lngSMCaptionHeight = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.SmallCaptionButtonHeight(Value)", Value
End Property
Public Property Get SmallCaptionFont() As Font
On Error GoTo errHandler
' Retrieve small caption bar font object.
Set SmallCaptionFont = oSMCaptionFont
Exit Property
errHandler:
ErrorIn "SystemMetrics.SmallCaptionFont"
End Property
Public Property Get MenuButtonWidth() As Long
On Error GoTo errHandler
' Set or retrieve the width of menu bar buttons.
MenuButtonWidth = ncm.lngMenuWidth
Exit Property
errHandler:
ErrorIn "SystemMetrics.MenuButtonWidth"
End Property
Public Property Let MenuButtonWidth(Value As Long)
On Error GoTo errHandler
' Set or retrieve the width of menu bar buttons.
ncm.lngMenuWidth = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.MenuButtonWidth(Value)", Value
End Property
Public Property Get MenuButtonHeight() As Long
On Error GoTo errHandler
' Set or retrieve the height of menu bar buttons.
MenuButtonHeight = ncm.lngMenuHeight
Exit Property
errHandler:
ErrorIn "SystemMetrics.MenuButtonHeight"
End Property
Public Property Let MenuButtonHeight(Value As Long)
On Error GoTo errHandler
' Set or retrieve the height of menu bar buttons.
ncm.lngMenuHeight = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.MenuButtonHeight(Value)", Value
End Property
Public Property Get MenuFont() As Font
On Error GoTo errHandler
' Retrieve menu font object.
Set MenuFont = oMenuFont
Exit Property
errHandler:
ErrorIn "SystemMetrics.MenuFont"
End Property
Public Property Get StatusFont() As Font
On Error GoTo errHandler
' Retrieve status bar font object.
Set StatusFont = oStatusFont
Exit Property
errHandler:
ErrorIn "SystemMetrics.StatusFont"
End Property
Public Property Get MessageFont() As Font
On Error GoTo errHandler
' Retrieve message box font object.
Set MessageFont = oMessageFont
Exit Property
errHandler:
ErrorIn "SystemMetrics.MessageFont"
End Property
Public Sub SaveSettings()
On Error GoTo errHandler
' Save all changed settings.
Dim lngLen As Long
lngLen = Len(ncm)
ncm.cbSize = lngLen
' Need to copy all the font values back into the
' LogFont structures.
Call GetFontInfo(ncm.lfCaptionFont, oCaptionFont)
Call GetFontInfo(ncm.lfMenuFont, oMenuFont)
Call GetFontInfo(ncm.lfMessageFont, oMessageFont)
Call GetFontInfo(ncm.lfSMCaptionFont, oSMCaptionFont)
Call GetFontInfo(ncm.lfStatusFont, oStatusFont)
' Now save all the settings back to Windows.
'Call SystemParametersInfoInfo(SPI_SETNONCLIENTMETRICS, _
Call SystemParametersInfo(SPI_SETNONCLIENTMETRICS, _
lngLen, ncm, SPIF_TELLALL)
Exit Sub
errHandler:
ErrorIn "SystemMetrics.SaveSettings"
End Sub
Private Sub SetFontInfo(lf As LogFont, oFont As Font)
On Error GoTo errHandler
' Get font info from a LOGFONT structure into a Font class.
With oFont
.Weight = lf.lfWeight
.StrikeOut = CBool(lf.lfStrikeOut)
.Underline = CBool(lf.lfUnderline)
.Italic = CBool(lf.lfItalic)
.FaceName = dhTrimNull(StrConv(lf.lfFaceName, vbUnicode))
.Size = CalcSize(lf.lfHeight, fToPoints:=True)
End With
Exit Sub
errHandler:
ErrorIn "SystemMetrics.SetFontInfo(lf,oFont)"
End Sub
Private Sub GetFontInfo(lf As LogFont, oFont As Font)
On Error GoTo errHandler
' Get font info from a Font class back into a LOGFONT structure.
With oFont
lf.lfWeight = .Weight
lf.lfStrikeOut = .StrikeOut
lf.lfUnderline = .Underline
lf.lfItalic = .Italic
lf.lfHeight = CalcSize(.Size, fToPoints:=False)
Call SetFaceName(lf, .FaceName)
End With
Exit Sub
errHandler:
ErrorIn "SystemMetrics.GetFontInfo(lf,oFont)"
End Sub
Private Function CalcSize(lngHeight As Long, _
fToPoints As Boolean) As Long
On Error GoTo errHandler
Dim lngLogPixelsY As Long
Dim hDC As Long
hDC = CreateIC("DISPLAY", "", "", 0&)
lngLogPixelsY = GetDeviceCaps(hDC, LOGPIXELSY)
Call DeleteDC(hDC)
If fToPoints Then
CalcSize = -Int(lngHeight * 72 / lngLogPixelsY)
Else
CalcSize = -Int(lngHeight * lngLogPixelsY / 72)
End If
Exit Function
errHandler:
ErrorIn "SystemMetrics.CalcSize(lngHeight,fToPoints)",
Array(lngHeight, fToPoints)
End Function
Private Sub SetFaceName(lf As LogFont, strValue As String)
On Error GoTo errHandler
' Given a string, get it back into the ANSI byte array
' contained within a LOGFONT structure.
Dim intLen As String
Dim intI As Integer
Dim varName As Variant
Dim abytTemp() As Byte
abytTemp = StrConv(strValue, vbFromUnicode)
intLen = UBound(abytTemp) + 1
' Make sure the string isn't too long.
If intLen > LF_FACESIZE - 1 Then
intLen = LF_FACESIZE - 1
End If
For intI = 0 To intLen - 1
lf.lfFaceName(intI) = abytTemp(intI)
Next intI
lf.lfFaceName(intI) = 0
Exit Sub
errHandler:
ErrorIn "SystemMetrics.SetFaceName(lf,strValue)"
End Sub
Private Sub Class_Terminate()
On Error GoTo errHandler
Set oCaptionFont = Nothing
Set oSMCaptionFont = Nothing
Set oMenuFont = Nothing
Set oStatusFont = Nothing
Set oMessageFont = Nothing
Exit Sub
errHandler:
ErrorIn "SystemMetrics.Class_Terminate", , EA_NORERAISE
ErrSaveToFile
End Sub
Public Property Get Caption() As Long
On Error GoTo errHandler
' Height, in pixels, of normal caption bar.
Caption = GetSystemMetrics(SM_CYCAPTION)
Exit Property
errHandler:
ErrorIn "SystemMetrics.Caption"
End Property
Public Property Get MenuHeight() As Long
On Error GoTo errHandler
' Height, in pixels, of normal single-line menu.
MenuHeight = GetSystemMetrics(SM_CYMENU)
Exit Property
errHandler:
ErrorIn "SystemMetrics.MenuHeight"
End Property
Public Property Get SmallCaption() As Long
On Error GoTo errHandler
' Height, in pixels, of a small caption bar.
SmallCaption = GetSystemMetrics(SM_CYSMCAPTION)
Exit Property
errHandler:
ErrorIn "SystemMetrics.SmallCaption"
End Property
Public Property Get FixedBorderX() As Long
On Error GoTo errHandler
' Retrieve the width in pixels, of the frame
' around the perimeter of a window that has a caption
' but is not sizable.
FixedBorderX = GetSystemMetrics(SM_CXFIXEDFRAME)
Exit Property
errHandler:
ErrorIn "SystemMetrics.FixedBorderX"
End Property
Public Property Get FixedBorderY() As Long
On Error GoTo errHandler
' Retrieve the height, in pixels, of the frame
' around the perimeter of a window that has a caption
' but is not sizable.
FixedBorderY = GetSystemMetrics(SM_CYFIXEDFRAME)
Exit Property
errHandler:
ErrorIn "SystemMetrics.FixedBorderY"
End Property
--------------------------------------------------------
'font.cls file
Option Explicit
'Used by SystemMetrics.cls
Public Enum FontWeights
FW_DONTCARE = 0
FW_THIN = 100
FW_EXTRALIGHT = 200
FW_LIGHT = 300
FW_NORMAL = 400
'FW_REGULAR = 400
FW_MEDIUM = 500
FW_SEMIBOLD = 600
FW_BOLD = 700
FW_EXTRABOLD = 800
FW_HEAVY = 900
End Enum
Public Size As Long
Public StrikeOut As Boolean
Public Weight As Long
Public Italic As Boolean
Public Underline As Boolean
Public FaceName As String
I want to change the scrollbar size of windows, How can I do that with
vb.net
I have find this in VB6 but how can we convert simply this code.
thx
VB6 sample
----------------------------------------------------
'SystemMetrics.csl file
Option Explicit
'Use Font.cls
Option Base 0 'Array begin from 0 to n
Private Const SM_CYCAPTION = 4
Private Const SM_CYMENU = 15
Private Const SM_CYSMCAPTION = 51
Private Const SM_CXDLGFRAME = 7
Private Const SM_CYDLGFRAME = 8
Private Const SM_CXFIXEDFRAME = SM_CXDLGFRAME
Private Const SM_CYFIXEDFRAME = SM_CYDLGFRAME
Const LF_FACESIZE = 32
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(0 To LF_FACESIZE - 1) As Byte
End Type
' SystemParametersInfo flags
Private Const SPIF_UPDATEINIFILE = &H1
Private Const SPIF_SENDWININICHANGE = &H2
' This is a made-up constant.
Private Const SPIF_TELLALL = SPIF_UPDATEINIFILE Or
SPIF_SENDWININICHANGE
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Const SPI_SETNONCLIENTMETRICS = 42
Private Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
Private Declare Function GetDeviceCaps _
Lib "gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function CreateIC _
Lib "gdi32" Alias "CreateICA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function DeleteDC _
Lib "gdi32" _
(ByVal hDC As Long) As Long
Private Declare Function SystemParametersInfo _
Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, ByVal uParam As Long, _
lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function GetSystemMetrics _
Lib "user32" _
(ByVal nIndex As Long) As Long
' NONCLIENTMETRICS Information
Private Type typNonClientMetrics
cbSize As Long
lngBorderWidth As Long
lngScrollWidth As Long
lngScrollHeight As Long
lngCaptionWidth As Long
lngCaptionHeight As Long
lfCaptionFont As LogFont
lngSMCaptionWidth As Long
lngSMCaptionHeight As Long
lfSMCaptionFont As LogFont
lngMenuWidth As Long
lngMenuHeight As Long
lfMenuFont As LogFont
lfStatusFont As LogFont
lfMessageFont As LogFont
End Type
Private ncm As typNonClientMetrics
Private oCaptionFont As Font
Private oSMCaptionFont As Font
Private oMenuFont As Font
Private oStatusFont As Font
Private oMessageFont As Font
Private Function dhTrimNull(strValue As String) As String
On Error GoTo errHandler
Dim intPos As Integer
intPos = InStr(strValue, vbNullChar)
Select Case intPos
Case 0
dhTrimNull = strValue
Case 1
dhTrimNull = vbNullString
Case Else
dhTrimNull = Left$(strValue, intPos - 1)
End Select
Exit Function
errHandler:
ErrorIn "SystemMetrics.dhTrimNull(strValue)", strValue
End Function
Private Sub Class_Initialize()
On Error GoTo errHandler
Dim lngLen As Long
lngLen = Len(ncm)
ncm.cbSize = lngLen
Call SystemParametersInfo(SPI_GETNONCLIENTMETRICS, _
lngLen, ncm, 0)
Set oCaptionFont = New Font
Set oSMCaptionFont = New Font
Set oMenuFont = New Font
Set oStatusFont = New Font
Set oMessageFont = New Font
Call SetFontInfo(ncm.lfCaptionFont, oCaptionFont)
Call SetFontInfo(ncm.lfMenuFont, oMenuFont)
Call SetFontInfo(ncm.lfMessageFont, oMessageFont)
Call SetFontInfo(ncm.lfSMCaptionFont, oSMCaptionFont)
Call SetFontInfo(ncm.lfStatusFont, oStatusFont)
Exit Sub
errHandler:
ErrorIn "SystemMetrics.Class_Initialize", , EA_NORERAISE
ErrSaveToFile
End Sub
Public Property Get BorderWidth() As Long
On Error GoTo errHandler
' Set or retrieve standard window borderwidth.
BorderWidth = ncm.lngBorderWidth
Exit Property
errHandler:
ErrorIn "SystemMetrics.BorderWidth"
End Property
Public Property Let BorderWidth(Value As Long)
On Error GoTo errHandler
' Set or retrieve standard window borderwidth.
ncm.lngBorderWidth = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.BorderWidth(Value)", Value
End Property
Public Property Get ScrollWidth() As Long
On Error GoTo errHandler
' Set or retrieve standard vertical scrollbar width.
ScrollWidth = ncm.lngScrollWidth
Exit Property
errHandler:
ErrorIn "SystemMetrics.ScrollWidth"
End Property
Public Property Let ScrollWidth(Value As Long)
On Error GoTo errHandler
' Set or retrieve standard vertical scrollbar width.
ncm.lngScrollWidth = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.ScrollWidth(Value)", Value
End Property
Public Property Get ScrollHeight() As Long
On Error GoTo errHandler
' Set or retrieve standard horizontal scrollbar height.
ScrollHeight = ncm.lngScrollHeight
Exit Property
errHandler:
ErrorIn "SystemMetrics.ScrollHeight"
End Property
Public Property Let ScrollHeight(Value As Long)
On Error GoTo errHandler
' Set or retrieve standard horizontal scrollbar height.
ncm.lngScrollHeight = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.ScrollHeight(Value)", Value
End Property
Public Property Get CaptionWidth() As Long
On Error GoTo errHandler
' Set or retrieve width of caption bar buttons.
CaptionWidth = ncm.lngCaptionWidth
Exit Property
errHandler:
ErrorIn "SystemMetrics.CaptionWidth"
End Property
Public Property Let CaptionWidth(Value As Long)
On Error GoTo errHandler
' Set or retrieve width of caption bar buttons.
ncm.lngCaptionWidth = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.CaptionWidth(Value)", Value
End Property
Public Property Get CaptionHeight() As Long
On Error GoTo errHandler
' Set or retrieve height of caption bar buttons.
CaptionHeight = ncm.lngCaptionHeight
Exit Property
errHandler:
ErrorIn "SystemMetrics.CaptionHeight"
End Property
Public Property Let CaptionHeight(Value As Long)
On Error GoTo errHandler
' Set or retrieve height of caption bar buttons.
ncm.lngCaptionHeight = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.CaptionHeight(Value)", Value
End Property
Public Property Get CaptionFont() As Font
On Error GoTo errHandler
' Retrieve caption bar font object.
Set CaptionFont = oCaptionFont
Exit Property
errHandler:
ErrorIn "SystemMetrics.CaptionFont"
End Property
Public Property Get SmallCaptionButtonWidth() As Long
On Error GoTo errHandler
' Set or retrieve width of small caption bar buttons.
SmallCaptionButtonWidth = ncm.lngSMCaptionWidth
Exit Property
errHandler:
ErrorIn "SystemMetrics.SmallCaptionButtonWidth"
End Property
Public Property Let SmallCaptionButtonWidth(Value As Long)
On Error GoTo errHandler
' Set or retrieve width of small caption bar buttons.
ncm.lngSMCaptionWidth = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.SmallCaptionButtonWidth(Value)", Value
End Property
Public Property Get SmallCaptionButtonHeight() As Long
On Error GoTo errHandler
' Set or retrieve height of small caption bar buttons.
SmallCaptionButtonHeight = ncm.lngSMCaptionHeight
Exit Property
errHandler:
ErrorIn "SystemMetrics.SmallCaptionButtonHeight"
End Property
Public Property Let SmallCaptionButtonHeight(Value As Long)
On Error GoTo errHandler
' Set or retrieve height of small caption bar buttons.
ncm.lngSMCaptionHeight = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.SmallCaptionButtonHeight(Value)", Value
End Property
Public Property Get SmallCaptionFont() As Font
On Error GoTo errHandler
' Retrieve small caption bar font object.
Set SmallCaptionFont = oSMCaptionFont
Exit Property
errHandler:
ErrorIn "SystemMetrics.SmallCaptionFont"
End Property
Public Property Get MenuButtonWidth() As Long
On Error GoTo errHandler
' Set or retrieve the width of menu bar buttons.
MenuButtonWidth = ncm.lngMenuWidth
Exit Property
errHandler:
ErrorIn "SystemMetrics.MenuButtonWidth"
End Property
Public Property Let MenuButtonWidth(Value As Long)
On Error GoTo errHandler
' Set or retrieve the width of menu bar buttons.
ncm.lngMenuWidth = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.MenuButtonWidth(Value)", Value
End Property
Public Property Get MenuButtonHeight() As Long
On Error GoTo errHandler
' Set or retrieve the height of menu bar buttons.
MenuButtonHeight = ncm.lngMenuHeight
Exit Property
errHandler:
ErrorIn "SystemMetrics.MenuButtonHeight"
End Property
Public Property Let MenuButtonHeight(Value As Long)
On Error GoTo errHandler
' Set or retrieve the height of menu bar buttons.
ncm.lngMenuHeight = Value
Call SaveSettings
Exit Property
errHandler:
ErrorIn "SystemMetrics.MenuButtonHeight(Value)", Value
End Property
Public Property Get MenuFont() As Font
On Error GoTo errHandler
' Retrieve menu font object.
Set MenuFont = oMenuFont
Exit Property
errHandler:
ErrorIn "SystemMetrics.MenuFont"
End Property
Public Property Get StatusFont() As Font
On Error GoTo errHandler
' Retrieve status bar font object.
Set StatusFont = oStatusFont
Exit Property
errHandler:
ErrorIn "SystemMetrics.StatusFont"
End Property
Public Property Get MessageFont() As Font
On Error GoTo errHandler
' Retrieve message box font object.
Set MessageFont = oMessageFont
Exit Property
errHandler:
ErrorIn "SystemMetrics.MessageFont"
End Property
Public Sub SaveSettings()
On Error GoTo errHandler
' Save all changed settings.
Dim lngLen As Long
lngLen = Len(ncm)
ncm.cbSize = lngLen
' Need to copy all the font values back into the
' LogFont structures.
Call GetFontInfo(ncm.lfCaptionFont, oCaptionFont)
Call GetFontInfo(ncm.lfMenuFont, oMenuFont)
Call GetFontInfo(ncm.lfMessageFont, oMessageFont)
Call GetFontInfo(ncm.lfSMCaptionFont, oSMCaptionFont)
Call GetFontInfo(ncm.lfStatusFont, oStatusFont)
' Now save all the settings back to Windows.
'Call SystemParametersInfoInfo(SPI_SETNONCLIENTMETRICS, _
Call SystemParametersInfo(SPI_SETNONCLIENTMETRICS, _
lngLen, ncm, SPIF_TELLALL)
Exit Sub
errHandler:
ErrorIn "SystemMetrics.SaveSettings"
End Sub
Private Sub SetFontInfo(lf As LogFont, oFont As Font)
On Error GoTo errHandler
' Get font info from a LOGFONT structure into a Font class.
With oFont
.Weight = lf.lfWeight
.StrikeOut = CBool(lf.lfStrikeOut)
.Underline = CBool(lf.lfUnderline)
.Italic = CBool(lf.lfItalic)
.FaceName = dhTrimNull(StrConv(lf.lfFaceName, vbUnicode))
.Size = CalcSize(lf.lfHeight, fToPoints:=True)
End With
Exit Sub
errHandler:
ErrorIn "SystemMetrics.SetFontInfo(lf,oFont)"
End Sub
Private Sub GetFontInfo(lf As LogFont, oFont As Font)
On Error GoTo errHandler
' Get font info from a Font class back into a LOGFONT structure.
With oFont
lf.lfWeight = .Weight
lf.lfStrikeOut = .StrikeOut
lf.lfUnderline = .Underline
lf.lfItalic = .Italic
lf.lfHeight = CalcSize(.Size, fToPoints:=False)
Call SetFaceName(lf, .FaceName)
End With
Exit Sub
errHandler:
ErrorIn "SystemMetrics.GetFontInfo(lf,oFont)"
End Sub
Private Function CalcSize(lngHeight As Long, _
fToPoints As Boolean) As Long
On Error GoTo errHandler
Dim lngLogPixelsY As Long
Dim hDC As Long
hDC = CreateIC("DISPLAY", "", "", 0&)
lngLogPixelsY = GetDeviceCaps(hDC, LOGPIXELSY)
Call DeleteDC(hDC)
If fToPoints Then
CalcSize = -Int(lngHeight * 72 / lngLogPixelsY)
Else
CalcSize = -Int(lngHeight * lngLogPixelsY / 72)
End If
Exit Function
errHandler:
ErrorIn "SystemMetrics.CalcSize(lngHeight,fToPoints)",
Array(lngHeight, fToPoints)
End Function
Private Sub SetFaceName(lf As LogFont, strValue As String)
On Error GoTo errHandler
' Given a string, get it back into the ANSI byte array
' contained within a LOGFONT structure.
Dim intLen As String
Dim intI As Integer
Dim varName As Variant
Dim abytTemp() As Byte
abytTemp = StrConv(strValue, vbFromUnicode)
intLen = UBound(abytTemp) + 1
' Make sure the string isn't too long.
If intLen > LF_FACESIZE - 1 Then
intLen = LF_FACESIZE - 1
End If
For intI = 0 To intLen - 1
lf.lfFaceName(intI) = abytTemp(intI)
Next intI
lf.lfFaceName(intI) = 0
Exit Sub
errHandler:
ErrorIn "SystemMetrics.SetFaceName(lf,strValue)"
End Sub
Private Sub Class_Terminate()
On Error GoTo errHandler
Set oCaptionFont = Nothing
Set oSMCaptionFont = Nothing
Set oMenuFont = Nothing
Set oStatusFont = Nothing
Set oMessageFont = Nothing
Exit Sub
errHandler:
ErrorIn "SystemMetrics.Class_Terminate", , EA_NORERAISE
ErrSaveToFile
End Sub
Public Property Get Caption() As Long
On Error GoTo errHandler
' Height, in pixels, of normal caption bar.
Caption = GetSystemMetrics(SM_CYCAPTION)
Exit Property
errHandler:
ErrorIn "SystemMetrics.Caption"
End Property
Public Property Get MenuHeight() As Long
On Error GoTo errHandler
' Height, in pixels, of normal single-line menu.
MenuHeight = GetSystemMetrics(SM_CYMENU)
Exit Property
errHandler:
ErrorIn "SystemMetrics.MenuHeight"
End Property
Public Property Get SmallCaption() As Long
On Error GoTo errHandler
' Height, in pixels, of a small caption bar.
SmallCaption = GetSystemMetrics(SM_CYSMCAPTION)
Exit Property
errHandler:
ErrorIn "SystemMetrics.SmallCaption"
End Property
Public Property Get FixedBorderX() As Long
On Error GoTo errHandler
' Retrieve the width in pixels, of the frame
' around the perimeter of a window that has a caption
' but is not sizable.
FixedBorderX = GetSystemMetrics(SM_CXFIXEDFRAME)
Exit Property
errHandler:
ErrorIn "SystemMetrics.FixedBorderX"
End Property
Public Property Get FixedBorderY() As Long
On Error GoTo errHandler
' Retrieve the height, in pixels, of the frame
' around the perimeter of a window that has a caption
' but is not sizable.
FixedBorderY = GetSystemMetrics(SM_CYFIXEDFRAME)
Exit Property
errHandler:
ErrorIn "SystemMetrics.FixedBorderY"
End Property
--------------------------------------------------------
'font.cls file
Option Explicit
'Used by SystemMetrics.cls
Public Enum FontWeights
FW_DONTCARE = 0
FW_THIN = 100
FW_EXTRALIGHT = 200
FW_LIGHT = 300
FW_NORMAL = 400
'FW_REGULAR = 400
FW_MEDIUM = 500
FW_SEMIBOLD = 600
FW_BOLD = 700
FW_EXTRABOLD = 800
FW_HEAVY = 900
End Enum
Public Size As Long
Public StrikeOut As Boolean
Public Weight As Long
Public Italic As Boolean
Public Underline As Boolean
Public FaceName As String