|
-
Mar 19th, 2025, 02:06 PM
#1
Thread Starter
Fanatic Member
 [RESOLVED] Scale and Position Glyph
Hello,
I want to scale and precisely position glyphs in my project.
I can get it to work, but I have to hard-code the position values.
I cannot figure out the math to automatically do this to any scale that may be set.
In this demo project I want to draw the "Upwards Arrow" glyph 1 pixel below the cross-hairs,
and be able to scale the glyph to whatever size I want.
Below is complete code for project.
I have colored red the hard-coded values that I would like to convert to a formula.
Form code:
Code:
Option Explicit
Dim gdiplusToken As Long
Dim stat As Long
Dim graphics As Long
Dim brushBlack As Long
Dim penRed As Long
Dim penGreen As Long
Dim fontFamily As Long
Public Enum TextJustify
JustifyCenter
JustifyLeft
JustifyRight
End Enum
Private Sub Form_Load()
Form1.Caption = "GDI+"
Form1.Width = Screen.TwipsPerPixelX * 600
Form1.Height = Screen.TwipsPerPixelY * 465
Form1.BackColor = &H8000000F
Form1.ScaleMode = vbPixels
Picture1.Appearance = 0
Picture1.Left = 16
Picture1.Top = 16
Picture1.Height = 366
Picture1.Width = 552
'Picture1.Font = "courier new"
Picture1.AutoRedraw = True
Picture1.ScaleMode = vbPixels
Command1.Width = Picture1.Width
Command1.Height = 25
Command1.Left = Picture1.Left
Command1.Top = Picture1.Top + Picture1.Height + 10
Command1.Caption = "Sacle and Position Glyph"
' Initialize Windows GDI+
Dim GdiplusStartupInput As GdiplusStartupInput
GdiplusStartupInput.GdiplusVersion = 1
GdiplusStartupInput.DebugEventCallback = 0
GdiplusStartupInput.SuppressBackgroundThread = False
GdiplusStartupInput.SuppressExternalCodecs = False
Dim status As GpStatus
status = GdiplusStartup(gdiplusToken, GdiplusStartupInput, 0)
If status <> Ok Then
MsgBox "Error loading GDI+!", vbCritical
Call GdiplusShutdown(gdiplusToken)
End If
Call GraphicsInitialize
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call GraphicsUninitialize
' Clean up resources used by Windows GDI+
Call GdiplusShutdown(gdiplusToken)
End Sub
Private Sub Command1_Click()
'Picture1.Cls
stat = GdipGraphicsClear(graphics, &HFFFFFFFF) 'clear to white
Call DrawSymbol(graphics)
Picture1.Refresh
End Sub
Public Sub DrawSymbol(graphics As Long)
stat = GdipCreateFontFamilyFromName(StrPtr("Times New Roman"), 0, fontFamily)
Dim desiredSize As Single
desiredSize = 50
Dim sString As String
sString = ChrW(&H2191) 'Upwards Arrow
Call DrawSymbolString(graphics, _
sString, _
0, 0, _
JustifyCenter, _
fontFamily, FontStyle.FontStyleRegular, desiredSize)
End Sub
Public Sub DrawSymbolString(G As Long, _
sString As String, _
x As Single, y As Single, _
Justify As TextJustify, _
fontFamily As Long, _
FontStyle As FontStyle, _
fontSize As Single)
'-------------------------------------------------------------------------------
' Draw crosshairs
Dim pt As POINTF
pt.x = Picture1.Width / 2:
pt.y = 150
stat = GdipDrawLine(G, penRed, pt.x - 20, pt.y, pt.x + 20, pt.y)
stat = GdipDrawLine(G, penRed, pt.x, pt.y - 20, pt.x, pt.y + 20)
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
' Create a string path
' Create StringFormat and set
Dim stringFormatGlyph As Long
stat = GdipStringFormatGetGenericTypographic(stringFormatGlyph)
stat = GdipSetStringFormatAlign(stringFormatGlyph, StringAlignmentCenter)
' Create string path
Dim pathString As Long
stat = GdipCreatePath(FillModeWinding, pathString)
' Set the layout rect for string path
Dim rct As RECTF
rct.Left = pt.x 'x
rct.Top = pt.y - 13 'y
rct.Right = 0 'width (0 means no boundary)
rct.Bottom = 0 'height (0 means no boundary)
' Add string to path
stat = GdipAddPathString(pathString, _
StrPtr(sString), -1, fontFamily, FontStyleRegular, fontSize, _
rct, stringFormatGlyph)
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
' Translate and Scale
Dim matrix As Long
stat = GdipCreateMatrix(matrix)
Dim scaleY As Single
'scaleY = 1
'scaleY = 1.5
'scaleY = 2
'scaleY = 3
scaleY = 4
Dim offsetY As Single
'offsetY = -23 'when ScaleY = 1
'offsetY = 34.5 'when ScaleY = 1.5
'offsetY = 63 'when ScaleY = 2
'offsetY = 91.5 'when ScaleY = 3
offsetY = 106 'when ScaleY = 4
stat = GdipTranslateMatrix(matrix, x - 0, y - offsetY, MatrixOrderAppend)
stat = GdipScaleMatrix(matrix, 1, scaleY, MatrixOrderAppend)
stat = GdipTransformPath(pathString, matrix)
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
' Draw string path
stat = GdipFillPath(graphics, brushBlack, pathString) 'fill path
'stat = GdipDrawPath(graphics, penRed, pathString) 'outline path
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
' Clean-up
stat = GdipDeleteStringFormat(stringFormatGlyph)
stat = GdipDeletePath(pathString)
stat = GdipDeleteMatrix(matrix)
'-------------------------------------------------------------------------------
End Sub
Public Sub GraphicsInitialize()
' Create GDI+ objects
stat = GdipCreateFromHDC(Picture1.hdc, graphics)
stat = GdipSetSmoothingMode(graphics, SmoothingModeAntiAlias) 'objects
stat = GdipSetTextRenderingHint(graphics, TextRenderingHintAntiAlias) 'text
stat = GdipCreateSolidFill(&HFF000000, brushBlack)
stat = GdipCreatePen1(&HFFFF0000, 1, UnitPixel, penRed)
stat = GdipCreatePen1(&HFF00FF00, 1, UnitPixel, penGreen)
End Sub
Public Sub GraphicsUninitialize()
' Clean-up GDI+ objects
stat = GdipDeleteFontFamily(fontFamily)
stat = GdipDeletePen(penRed)
stat = GdipDeletePen(penGreen)
stat = GdipDeleteBrush(brushBlack)
stat = GdipDeleteGraphics(graphics)
End Sub
Module code:
Code:
Option Explicit
Public Type POINTF
x As Single
y As Single
End Type
Public Type RECTF
Left As Single
Top As Single
Right As Single
Bottom As Single
End Type
Public Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Public Enum GpStatus
Ok = 0
GenericError = 1
InvalidParameter = 2
OutOfMemory = 3
ObjectBusy = 4
InsufficientBuffer = 5
NotImplemented = 6
Win32Error = 7
WrongState = 8
Aborted = 9
FileNotFound = 10
ValueOverflow = 11
AccessDenied = 12
UnknownImageFormat = 13
FontFamilyNotFound = 14
FontStyleNotFound = 15
NotTrueTypeFont = 16
UnsupportedGdiplusVersion = 17
GdiplusNotInitialized = 18
PropertyNotFound = 19
PropertyNotSupported = 20
End Enum
Public Enum GpUnit
UnitWorld
UnitDisplay
UnitPixel
UnitPoint
UnitInch
UnitDocument
UnitMillimeter
End Enum
Public Enum QualityMode
QualityModeInvalid = -1
QualityModeDefault = 0
QualityModeLow = 1
QualityModeHigh = 2
End Enum
Public Enum FontStyle
FontStyleRegular = 0
FontStyleBold = 1
FontStyleItalic = 2
FontStyleBoldItalic = 3
FontStyleUnderline = 4
FontStyleStrikeout = 8
End Enum
Public Enum StringAlignment
StringAlignmentNear = 0
StringAlignmentCenter = 1
StringAlignmentFar = 2
End Enum
Public Enum SmoothingMode
SmoothingModeInvalid = QualityModeInvalid
SmoothingModeDefault = QualityModeDefault
SmoothingModeHighSpeed = QualityModeLow
SmoothingModeHighQuality = QualityModeHigh
SmoothingModeNone
SmoothingModeAntiAlias
End Enum
Public Enum TextRenderingHint
TextRenderingHintSystemDefault = 0
TextRenderingHintSingleBitPerPixelGridFit
TextRenderingHintSingleBitPerPixel
TextRenderingHintAntiAliasGridFit
TextRenderingHintAntiAlias
TextRenderingHintClearTypeGridFit
End Enum
Public Enum FillMode
FillModeAlternate
FillModeWinding
End Enum
Public Enum MatrixOrder
MatrixOrderPrepend = 0
MatrixOrderAppend = 1
End Enum
Public Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Public Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
Public Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, graphics As Long) As GpStatus
Public Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GpStatus
Public Declare Function GdipSetSmoothingMode Lib "gdiplus" (ByVal graphics As Long, ByVal SmoothingMd As SmoothingMode) As GpStatus
Public Declare Function GdipSetTextRenderingHint Lib "gdiplus" (ByVal graphics As Long, ByVal mode As TextRenderingHint) As GpStatus
Public Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal graphics As Long, ByVal lColor As Long) As GpStatus
Public Declare Function GdipDrawLine Lib "gdiplus" (ByVal graphics As Long, ByVal pen As Long, ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single, ByVal y2 As Single) As GpStatus
Public Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal argb As Long, brush As Long) As GpStatus
Public Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal brush As Long) As GpStatus
Public Declare Function GdipCreatePen1 Lib "gdiplus" (ByVal color As Long, ByVal Width As Single, ByVal unit As GpUnit, pen As Long) As GpStatus
Public Declare Function GdipDeletePen Lib "gdiplus" (ByVal pen As Long) As GpStatus
Public Declare Function GdipCreateFontFamilyFromName Lib "gdiplus" (ByVal name As Long, ByVal fontCollection As Long, fontFamily As Long) As GpStatus
Public Declare Function GdipDeleteFontFamily Lib "gdiplus" (ByVal fontFamily As Long) As GpStatus
Public Declare Function GdipStringFormatGetGenericTypographic Lib "gdiplus" (StringFormat As Long) As GpStatus
Public Declare Function GdipSetStringFormatAlign Lib "gdiplus" (ByVal StringFormat As Long, ByVal align As StringAlignment) As GpStatus
Public Declare Function GdipDeleteStringFormat Lib "gdiplus" (ByVal StringFormat As Long) As GpStatus
Public Declare Function GdipCreateMatrix Lib "gdiplus" (matrix As Long) As GpStatus
Public Declare Function GdipDeleteMatrix Lib "gdiplus" (ByVal matrix As Long) As GpStatus
Public Declare Function GdipTranslateMatrix Lib "gdiplus" (ByVal matrix As Long, ByVal offsetX As Single, ByVal offsetY As Single, ByVal order As MatrixOrder) As GpStatus
Public Declare Function GdipScaleMatrix Lib "gdiplus" (ByVal matrix As Long, ByVal scaleX As Single, ByVal scaleY As Single, ByVal order As MatrixOrder) As GpStatus
Public Declare Function GdipCreatePath Lib "gdiplus" (ByVal brushmode As FillMode, path As Long) As GpStatus
Public Declare Function GdipDeletePath Lib "gdiplus" (ByVal path As Long) As GpStatus
Public Declare Function GdipFillPath Lib "gdiplus" (ByVal graphics As Long, ByVal brush As Long, ByVal path As Long) As GpStatus
Public Declare Function GdipDrawPath Lib "gdiplus" (ByVal graphics As Long, ByVal pen As Long, ByVal path As Long) As GpStatus
Public Declare Function GdipAddPathString Lib "gdiplus" (ByVal path As Long, ByVal str As Long, ByVal length As Long, ByVal family As Long, ByVal style As Long, ByVal emSize As Single, layoutRect As RECTF, ByVal StringFormat As Long) As GpStatus
Public Declare Function GdipTransformPath Lib "gdiplus" (ByVal path As Long, ByVal matrix As Long) As GpStatus
-
Mar 19th, 2025, 07:55 PM
#2
Lively Member
Re: Scale and Position Glyph
With some help from Claude, the below code works. I haven't read through it, so hopefully it's not doing any wacky LLM ****.
add this definition:
Code:
Public Declare Function GdipGetPathWorldBounds Lib "gdiplus" ( _
ByVal path As Long, _
ByRef bounds As RECTF, _
ByVal matrix As Long, _
ByVal pen As Long _
) As GpStatus
Change DrawSymbolString:
Code:
Public Sub DrawSymbolString(G As Long, _
sString As String, _
x As Single, y As Single, _
Justify As TextJustify, _
fontFamily As Long, _
FontStyle As FontStyle, _
fontSize As Single)
'-------------------------------------------------------------------------------
' Draw crosshairs
Dim pt As POINTF
pt.x = Picture1.Width / 2
pt.y = 150
stat = GdipDrawLine(G, penRed, pt.x - 20, pt.y, pt.x + 20, pt.y)
stat = GdipDrawLine(G, penRed, pt.x, pt.y - 20, pt.x, pt.y + 20)
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
' Create a string path
' Create StringFormat and set
Dim stringFormatGlyph As Long
stat = GdipStringFormatGetGenericTypographic(stringFormatGlyph)
stat = GdipSetStringFormatAlign(stringFormatGlyph, StringAlignmentCenter)
' Create string path
Dim pathString As Long
stat = GdipCreatePath(FillModeWinding, pathString)
' Set desired scale factor
Dim scaleY As Single
scaleY = 8 ' Change this value as needed
' Calculate position to account for scaling
' When we scale, we need to offset by (1 - scale)/2 to maintain top edge position
Dim adjustedY As Single
adjustedY = pt.y + 1 - ((scaleY - 1) / 2)
' Set the layout rect for string path with the adjusted Y position
Dim rct As RECTF
rct.Left = pt.x 'x
rct.Top = adjustedY 'y - adjusted to account for scaling
rct.Right = 0 'width (0 means no boundary)
rct.Bottom = 0 'height (0 means no boundary)
' Add string to path
stat = GdipAddPathString(pathString, _
StrPtr(sString), -1, fontFamily, FontStyleRegular, fontSize, _
rct, stringFormatGlyph)
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
' Apply scaling
' Create transformation matrix
Dim matrix As Long
stat = GdipCreateMatrix(matrix)
' Get path bounds before scaling
Dim pathBounds As RECTF
stat = GdipGetPathWorldBounds(pathString, pathBounds, 0, 0)
' We want the top edge of the arrow to stay at pt.y + 1
' Calculate the anchor point for scaling
Dim anchorY As Single
anchorY = pathBounds.Top
' Scale around the top edge
stat = GdipTranslateMatrix(matrix, 0, -anchorY, MatrixOrderAppend)
stat = GdipScaleMatrix(matrix, 1, scaleY, MatrixOrderAppend)
stat = GdipTranslateMatrix(matrix, 0, anchorY, MatrixOrderAppend)
' Apply transform
stat = GdipTransformPath(pathString, matrix)
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
' Draw string path
stat = GdipFillPath(graphics, brushBlack, pathString) 'fill path
' Optional: Draw the bounding box for debugging
'Dim finalBounds As RECTF
'stat = GdipGetPathWorldBounds(pathString, finalBounds, 0, 0)
'stat = GdipDrawRectangle(G, penGreen, finalBounds.Left, finalBounds.Top, _
' finalBounds.Right - finalBounds.Left, finalBounds.Bottom - finalBounds.Top)
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
' Clean-up
stat = GdipDeleteStringFormat(stringFormatGlyph)
stat = GdipDeletePath(pathString)
stat = GdipDeleteMatrix(matrix)
'-------------------------------------------------------------------------------
End Sub
-
Mar 20th, 2025, 06:37 AM
#3
Thread Starter
Fanatic Member
Re: Scale and Position Glyph
Works perfectly!! 
Thanks bahbahbah
(Thanks Claude)
Just curios...
Claude's code verbatim, and no tweaking on your part?
(Amazing in my opinion if so)
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|
Reply With Quote