Rotating TEXT in PictureBox

[GeoMEM]

Hi,

We're trying to draw a geographic grid (successfull) in
a PictureBox - BUT we now need to place text along the
grid lines. This means rotating one set of text through
90 degrees.

This was dead easy in Borland Pascal for DOS from 1992.
BUT for some reason it's not even mentioned in Microsoft
VB6 1999 vintage.

Am I missing something here or is Visual Basic about 10 years behind the times in functionality?

Any help on displaying rotated text would be much appreciated.

Thanks

James

[Alfred]

Option Explicit

Public Const GM_COMPATIBLE = 1
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, _
ByVal O As Long, ByVal W As Long, ByVal i As Long, ByVal u As Long, ByVal S As Long, _
ByVal c As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal f As String) As Long
Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
Declare Function GetTextFace Lib "gdi32" Alias "GetTextFaceA" (ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String) As Long
Declare Function SetGraphicsMode Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long) As Long
Declare Function ApiTextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long


Public Const LF_FACESIZE = 32

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(LF_FACESIZE) As Byte
End Type

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

'---------------------------------------------------------------------------------------------
' Notes for VB 5 service pack 2 & 3:
' 1) First parameter: "O as Object" can be Form/PictureBox or Printer object
' 2) In this function don't reference the printer object after creating the device context handle (hDC).
' If you do, you will loose the font you created. This is a bug in VB5 introduced by MS (fixed in VB6)
' 3) Not all font types do rotate properly (Use Courier New or Arial)
'---------------------------------------------------------------------------------------------
Sub TextOut(O As Object, ByVal x As Single, ByVal y As Single, ByVal text As String, Optional Angle As Long = 900)

Dim hdc As Long, hFont As Long, X_Pixels As Long, Y_Pixels As Long, retval As Long, hFontOld As Long
Dim TM As TEXTMETRIC, LF As LOGFONT, FaceName As String * 255, FontSize As Single

' Save font size
FontSize = O.FontSize
' X,Y coordinates from logical units to device units (=pixels), required by ApiTextOut
X_Pixels = O.ScaleX(x - O.ScaleLeft, O.ScaleMode, vbPixels)
Y_Pixels = O.ScaleY(y - O.ScaleTop, O.ScaleMode, vbPixels)
' Get reference to devide context handle
' Don't use object O anywhere else in this function (see note above)!!!!!!
hdc = O.hdc
' Set Win NT and Win 95 compatible graphics modes
retval = SetGraphicsMode(hdc, GM_COMPATIBLE)
' Get current font properties
GetTextMetrics hdc, TM
GetTextFace hdc, 255, FaceName
' Create new font similar to the existing font but rotated (Escapment = 900 and Orientation = 900)
hFont = CreateFont((TM.tmHeight + TM.tmExternalLeading), TM.tmAveCharWidth, Angle, Angle, _
TM.tmWeight, TM.tmItalic, TM.tmUnderlined, TM.tmStruckOut, _
TM.tmCharSet, 0, 0, 0, TM.tmPitchAndFamily, FaceName)
' Select font into device context
hFontOld = SelectObject(hdc, hFont)
' Output text onto device context
retval = ApiTextOut(hdc, X_Pixels, Y_Pixels, text, Len(text))
' Restore old font and delete rotated font
Call DeleteObject(SelectObject(hdc, hFontOld))
' Restore font size
O.FontSize = FontSize
End Sub