TextMove




Option Explicit
Private Const LF_FACESIZE = 32
Private Const OUT_DEFAULT_PRECIS = 0
Private Const OUT_STRING_PRECIS = 1
Private Const OUT_CHARACTER_PRECIS = 2
Private Const OUT_STROKE_PRECIS = 3
Private Const OUT_TT_PRECIS = 4
Private Const OUT_DEVICE_PRECIS = 5
Private Const OUT_RASTER_PRECIS = 6
Private Const OUT_TT_ONLY_PRECIS = 7
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const CLIP_CHARACTER_PRECIS = 1
Private Const CLIP_STROKE_PRECIS = 2
Private Const CLIP_LH_ANGLES = &H10
Private Const CLIP_TT_ALWAYS = &H20
Private Const CLIP_EMBEDDED = &H80
Private Const DEFAULT_QUALITY = 0
Private Const DRAFT_QUALITY = 1
Private Const PROOF_QUALITY = 2
Private Const DEFAULT_PITCH = 0
Private Const FIXED_PITCH = 1
Private Const VARIABLE_PITCH = 2
Private Const TMPF_FIXED_PITCH = 1
Private Const TMPF_VECTOR = 2
Private Const TMPF_DEVICE = 8
Private Const TMPF_TRUETYPE = 4
Private Const ANSI_CHARSET = 0
Private Const DEFAULT_CHARSET = 1
Private Const SYMBOL_CHARSET = 2
Private Const SHIFTJIS_CHARSET = 128
Private Const OEM_CHARSET = 255
Private Const NTM_REGULAR = &H40&
Private Const NTM_BOLD = &H20&
Private Const NTM_ITALIC = &H1&
Private Const LF_FULLFACESIZE = 64
Private Const RASTER_FONTTYPE = 1
Private Const DEVICE_FONTTYPE = 2
Private Const TRUETYPE_FONTTYPE = 4
Private Const FF_DONTCARE = 0
Private Const FF_ROMAN = 16
Private Const FF_SWISS = 32
Private Const FF_MODERN = 48
Private Const FF_SCRIPT = 64
Private Const FF_DECORATIVE = 80
Private Const FW_DONTCARE = 0
Private Const FW_THIN = 100
Private Const FW_EXTRALIGHT = 200
Private Const FW_LIGHT = 300
Private Const FW_NORMAL = 400
Private Const FW_MEDIUM = 500
Private Const FW_SEMIBOLD = 600
Private Const FW_BOLD = 700
Private Const FW_EXTRABOLD = 800
Private Const FW_HEAVY = 900
Private Const FW_ULTRALIGHT = FW_EXTRALIGHT
Private Const FW_REGULAR = FW_NORMAL
Private Const FW_DEMIBOLD = FW_SEMIBOLD
Private Const FW_ULTRABOLD = FW_EXTRABOLD
Private Const FW_BLACK = FW_HEAVY
Private Const GCP_DBCS = &H1
Private Const GCP_REORDER = &H2
Private Const GCP_USEKERNING = &H8
Private Const GCP_GLYPHSHAPE = &H10
Private Const GCP_LIGATE = &H20
Private Const GCP_DIACRITIC = &H100
Private Const GCP_KASHIDA = &H400
Private Const GCP_ERROR = &H8000
Private Const FLI_MASK = &H103B
Private Const GCP_JUSTIFY = &H10000
Private Const GCP_NODIACRITICS = &H20000
Private Const FLI_GLYPHS = &H40000
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private 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
Private Type NEWTEXTMETRIC
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
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth 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(LF_FACESIZE - 1) As Byte
End Type
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long)
Private Declare Function GetClientRect& Lib "user32" (ByVal hwnd As Long, lpRect As RECT)
Private Declare Function GetTextMetrics& Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC)
Private Declare Function GetTextFace& Lib "gdi32" Alias "GetTextFaceA" (ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long) Private Declare Function TextOut 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
Private Declare Function GetFontLanguageInfo& Lib "gdi32" (ByVal hdc As Long)
Private Sub Command1_Click()
Dim lf As LOGFONT
Dim FontToUse As Long
Dim oldHdc As Long
Dim dl As Long
Dim TestoProva As String
Dim rc As RECT
Dim TempByteArray() As Byte
Dim ByteArrayLimit As Long
Dim i As Long
TestoProva = "Prova"
TempByteArray = StrConv("Times" & Chr$(0), vbFromUnicode)
ByteArrayLimit = UBound(TempByteArray)
For i = 0 To ByteArrayLimit
lf.lfFaceName(i) = TempByteArray(i)
Next i
With lf
.lfHeight = 10
.lfWidth = 10
.lfWeight = 400
.lfQuality = DEFAULT_QUALITY
.lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
.lfCharSet = DEFAULT_CHARSET
.lfOutPrecision = OUT_DEFAULT_PRECIS
.lfClipPrecision = OUT_DEFAULT_PRECIS
.lfEscapement = 300
.lfOrientation = 300
End With
'// Creiamo un font ruotato.

FontToUse = CreateFontIndirect(lf)
If FontToUse = 0 Then Exit Sub '// In caso di Errore
'// Selezioniamo il font nel device context della picture

oldHdc = SelectObject(pic.hdc, FontToUse)
'// Da dove cominciamo a scrivere?

pic.CurrentX = (pic.Height - pic.Top) / 2
pic.CurrentY = (pic.Width - pic.Left) / 2
'// Scriviamo

pic.Print TestoProva
'// Ripristiniamo l'hdc nello stato in cui era prima.

dl = SelectObject(pic.hdc, oldHdc)
End Sub

Private Sub Form_Load()
End Sub

Fai un progetto con un command button e una picturebox chiamata pic.
E' qui che verra' fatta la scritta. Se preferisci scrivere
direttamente su form o su un altro controllo, passa a SelectObject
l'hDC della finestra sulla quale vuoi scrivere.










( textmove.html )- by Paolo Puglisi - Modifica del 17/12/2023