D
Doug
I need to programicaly change the worksheet top and bottom margins if
the header or footer text height is larger then the available space.
Lets say the user sets the default top margin to 1 inch but wants to
display two lines of text in Times New Roman font size 26. Now this
needs more room than a 1 inch margin. So I want to get the text height
and set the top or bottom margin.
I am getting the string height like this:
Dim strSize as size
Dim strHeight as single
Dim numLines as single
numLines= getNumLines(sString)
strSize= GetStringSize(sString,fntName,fntSize)
strHeight=strSize.cy * numLines
ActiveSheet.pagesetup.TopMargin=strHeight
For the above example the strHeight is 80 points or 1.11 inches which
is too small. So I thought that I needed to add the line spacing to
the equation. I found an article on MSDN that the default Windows line
spacing is tmHeight - tmExternalLeading but when I tried this the
result is way too big.
I have also tried:
1. Adding the printers hard margin to the equation
2. Tried to pass a printer device context to the GetTextExtentPoint32
function
3. Tried creating a TextBox object with auto size and get the height
Nothing I've tried is working. Does any one know what I'm doing
wrong?
Here is some test code the reports the string height
Public Type size
cx As Long
cy As Long
End Type
Public Const LOGPIXELSX = 88 ' Logical pixels/inch in X
Public Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
Public Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
'Device caps constants
Global Const DRIVERVERSION = 0
Global Const TECHNOLOGY = 2
Global Const HORZSIZE = 4
Global Const VERTSIZE = 6
Global Const HORZRES = 8
Global Const VERTRES = 10
Global Const BITSPIXEL = 12
Global Const PLANES = 14
Global Const NUMBRUSHES = 16
Global Const NUMPENS = 18
Global Const NUMMARKERS = 20
Global Const NUMFONTS = 22
Global Const NUMCOLORS = 24
Global Const PDEVICESIZE = 26
Global Const CURVECAPS = 28
Global Const LINECAPS = 30
Global Const POLYGONALCAPS = 32
Global Const TEXTCAPS = 34
Global Const CLIPCAPS = 36
Global Const RASTERCAPS = 38
Global Const ASPECTX = 40
Global Const ASPECTY = 42
Global Const ASPECTXY = 44
Global Const PHYSICALWIDTH = 110
Global Const PHYSICALHEIGHT = 111
Global Const PHYSICALOFFSETX = 112
Global Const PHYSICALOFFSETY = 113
Global Const SCALINGFACTORX = 114
Global Const SCALINGFACTORY = 115
Public Declare Function GetTextMetrics Lib "gdi32" Alias
"GetTextMetricsA" ( _
ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
Public Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" ( _
ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal
lpOutput As Long, _
ByVal lpInitData As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As
Long
Public Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" ( _
ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As
Long, _
ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic
As Long, _
ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal
fdwCharSet As Long, _
ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, _
ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal
lpszFace As String) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Public Declare Function SelectObject Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias
"GetTextExtentPoint32A" _
(ByVal hdc As Long, _
ByVal lpsz As String, _
ByVal cbString As Long, _
lpSize As size) As Long
Function getNumLines(text As String, Optional delim As String) As
Integer
If Len(delim) = 0 Then
delim = Chr(10)
End If
n = Split(text, delim)
getNumLines = UBound(n) + 1
End Function
Public Function GetStringSize(sString As String, sFontName As String,
fPointSize As Single) As size
Dim fnt As Font
Dim iFontSize As Long
Dim hdc As Long
Dim hFont As Long, hFontOld As Long
Dim Metrics As TEXTMETRIC
Dim fPixelsPerPoint As Single
Dim stringSize As size
'Create a Device Context, pretending we wanted to
'write into it:
hdc = CreateDC("DISPLAY", vbNullString, 0, 0)
'turn the nominal font size (in points) into
'a device-specific size in pixels:
fPixelsPerPoint = GetDeviceCaps(hdc, LOGPIXELSY) / 72
iFontSize = fPointSize * fPixelsPerPoint
'Prepare a font for printing into the Device Context:
hFont = CreateFont(-iFontSize, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
sFontName)
hFontOld = SelectObject(hdc, hFont)
GetTextExtentPoint32 hdc, sString, Len(sString), stringSize
GetStringSize = stringSize
'Tidy up:
SelectObject hdc, hFontOld
DeleteObject hFont
DeleteDC hdc
End Function
Sub testStringHeight()
Dim strSize As size
Dim strHeight As Single
Dim numLines As Single
Dim sString As String
Dim fntName As String
Dim fntSize As Single
fntName = "Times New Roman"
fntSize = 26
sString = "Line1" & Chr(10) & "Line2"
numLines = getNumLines(sString)
strSize = GetStringSize(sString, fntName, fntSize)
strHeight = strSize.cy * numLines
MsgBox strHeight
End Sub
the header or footer text height is larger then the available space.
Lets say the user sets the default top margin to 1 inch but wants to
display two lines of text in Times New Roman font size 26. Now this
needs more room than a 1 inch margin. So I want to get the text height
and set the top or bottom margin.
I am getting the string height like this:
Dim strSize as size
Dim strHeight as single
Dim numLines as single
numLines= getNumLines(sString)
strSize= GetStringSize(sString,fntName,fntSize)
strHeight=strSize.cy * numLines
ActiveSheet.pagesetup.TopMargin=strHeight
For the above example the strHeight is 80 points or 1.11 inches which
is too small. So I thought that I needed to add the line spacing to
the equation. I found an article on MSDN that the default Windows line
spacing is tmHeight - tmExternalLeading but when I tried this the
result is way too big.
I have also tried:
1. Adding the printers hard margin to the equation
2. Tried to pass a printer device context to the GetTextExtentPoint32
function
3. Tried creating a TextBox object with auto size and get the height
Nothing I've tried is working. Does any one know what I'm doing
wrong?
Here is some test code the reports the string height
Public Type size
cx As Long
cy As Long
End Type
Public Const LOGPIXELSX = 88 ' Logical pixels/inch in X
Public Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
Public Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
'Device caps constants
Global Const DRIVERVERSION = 0
Global Const TECHNOLOGY = 2
Global Const HORZSIZE = 4
Global Const VERTSIZE = 6
Global Const HORZRES = 8
Global Const VERTRES = 10
Global Const BITSPIXEL = 12
Global Const PLANES = 14
Global Const NUMBRUSHES = 16
Global Const NUMPENS = 18
Global Const NUMMARKERS = 20
Global Const NUMFONTS = 22
Global Const NUMCOLORS = 24
Global Const PDEVICESIZE = 26
Global Const CURVECAPS = 28
Global Const LINECAPS = 30
Global Const POLYGONALCAPS = 32
Global Const TEXTCAPS = 34
Global Const CLIPCAPS = 36
Global Const RASTERCAPS = 38
Global Const ASPECTX = 40
Global Const ASPECTY = 42
Global Const ASPECTXY = 44
Global Const PHYSICALWIDTH = 110
Global Const PHYSICALHEIGHT = 111
Global Const PHYSICALOFFSETX = 112
Global Const PHYSICALOFFSETY = 113
Global Const SCALINGFACTORX = 114
Global Const SCALINGFACTORY = 115
Public Declare Function GetTextMetrics Lib "gdi32" Alias
"GetTextMetricsA" ( _
ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
Public Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" ( _
ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal
lpOutput As Long, _
ByVal lpInitData As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As
Long
Public Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" ( _
ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As
Long, _
ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic
As Long, _
ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal
fdwCharSet As Long, _
ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, _
ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal
lpszFace As String) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Public Declare Function SelectObject Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias
"GetTextExtentPoint32A" _
(ByVal hdc As Long, _
ByVal lpsz As String, _
ByVal cbString As Long, _
lpSize As size) As Long
Function getNumLines(text As String, Optional delim As String) As
Integer
If Len(delim) = 0 Then
delim = Chr(10)
End If
n = Split(text, delim)
getNumLines = UBound(n) + 1
End Function
Public Function GetStringSize(sString As String, sFontName As String,
fPointSize As Single) As size
Dim fnt As Font
Dim iFontSize As Long
Dim hdc As Long
Dim hFont As Long, hFontOld As Long
Dim Metrics As TEXTMETRIC
Dim fPixelsPerPoint As Single
Dim stringSize As size
'Create a Device Context, pretending we wanted to
'write into it:
hdc = CreateDC("DISPLAY", vbNullString, 0, 0)
'turn the nominal font size (in points) into
'a device-specific size in pixels:
fPixelsPerPoint = GetDeviceCaps(hdc, LOGPIXELSY) / 72
iFontSize = fPointSize * fPixelsPerPoint
'Prepare a font for printing into the Device Context:
hFont = CreateFont(-iFontSize, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
sFontName)
hFontOld = SelectObject(hdc, hFont)
GetTextExtentPoint32 hdc, sString, Len(sString), stringSize
GetStringSize = stringSize
'Tidy up:
SelectObject hdc, hFontOld
DeleteObject hFont
DeleteDC hdc
End Function
Sub testStringHeight()
Dim strSize As size
Dim strHeight As Single
Dim numLines As Single
Dim sString As String
Dim fntName As String
Dim fntSize As Single
fntName = "Times New Roman"
fntSize = 26
sString = "Line1" & Chr(10) & "Line2"
numLines = getNumLines(sString)
strSize = GetStringSize(sString, fntName, fntSize)
strHeight = strSize.cy * numLines
MsgBox strHeight
End Sub