I have found this code for printing rotated text on a picturebox somewhere and have modified it, but apparently not properly,as it does not want to print transparent text.
If someone can help me make it a robust routine I would appreciate it.
In my declarations I have:
Code:
Public Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LogFont) 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
Public 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 ' or Boolean
Public Const LF_FACESIZE = 32
Public 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 As String * LF_FACESIZE
End Type
Code:
Public Sub PrintRotatedText(pic As PictureBox, MyText As String, X As Single, Y As Single, Degrees As Single, FontName As String, FontSize As Integer, FontBold As Boolean, FontTransparent As Boolean, Optional FontItalic As Boolean = False, Optional FontUnderline As Boolean = False)
Dim Angle As Long, Pic_hDC As Long, Log_Font As LogFont, New_Font As Long, Old_Font As Long
Dim picFontname As String, picFontsize As Integer, picFontTransparent As Boolean, picFontBold As Boolean, picFontItalic As Boolean, picFontUnderline As Boolean, picForeColour As Long, picScaleMode As Integer
'get the default properties of this picturebox
picFontname = pic.FontName
picFontsize = pic.FontSize
picFontTransparent = pic.FontTransparent
picFontItalic = pic.FontItalic
picFontUnderline = pic.FontUnderline
picFontBold = pic.FontBold
picForeColour = pic.ForeColor
picScaleMode = pic.ScaleMode
pic.FontTransparent = FontTransparent
'pic.ScaleMode = vbTwips
pic.FontName = FontName
pic.FontSize = FontSize
pic.FontBold = FontBold
pic.FontItalic = FontItalic
pic.FontUnderline = FontUnderline
pic.FontTransparent = FontTransparent
'Picture1.FontStrikethru = False
'Picture1.Print "A Rotated Text Example"
With pic
X = .ScaleX(X - .ScaleLeft, .ScaleMode, vbPixels)
Y = .ScaleY(Y - .ScaleTop, .ScaleMode, vbPixels)
Pic_hDC = .hDC
End With
With Log_Font
.lfEscapement = Degrees * 10
.lfHeight = pic.FontSize / Printer.TwipsPerPixelY
.lfFaceName = FontName & vbNullChar
.lfWeight = IIf(pic.FontBold = True, 700, 400)
.lfItalic = FontItalic
.lfUnderline = FontUnderline
End With
New_Font = CreateFontIndirect(Log_Font)
Old_Font = SelectObject(Pic_hDC, New_Font)
Call TextOut(Pic_hDC, X, Y, MyText, Len(MyText))
Call SelectObject(Pic_hDC, Old_Font)
Call DeleteObject(New_Font)
'reset the default properties of this picturebox
pic.FontName = picFontname
pic.FontSize = picFontsize
pic.FontTransparent = picFontTransparent
pic.FontItalic = picFontItalic
pic.FontUnderline = picFontUnderline
pic.FontBold = picFontBold
pic.ForeColor = picForeColour
'pic.ScaleMode = picScaleMode
End Sub
Did you try using ..
Public Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
'with nBkMode Constants
Public Const TRANSPARENT = 1
Public Const OPAQUE = 2
Did you try using ..
Public Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
'with nBkMode Constants
Public Const TRANSPARENT = 1
Public Const OPAQUE = 2
I have studied and implemented the code of both links given above.
In fact, both links of Arnoutdv give different and unworkable implementations of the font name, rotation and size.
Is there somebody with a simple routine not involving unnecessary, unreadable and faulty code?
It is probably quicker to just look up the GDI calls yourself. Most of the documentation that came with VB6 is still current enough for most purposes, making the process quicker than searching the web for updated versions of the info.
Here I target the Form (AutoRedraw = True) itself rather than a PictureBox, but the calls are the same:
Code:
Private Sub Form_Load()
Dim Text As String
Dim TextColorPrev As Long
Dim LOGFONT As LOGFONT
Dim hFont As Long
Dim hFontPrev As Long
Dim BkColorPrev As Long
Dim BkModePrev As BkModes
'Use current font w/o rotation:
Text = "Plain Text"
TextColorPrev = SetTextColor(hDC, vbWhite)
TextOut hDC, 0, 0, StrPtr(Text), Len(Text)
'Use rotated font:
Text = "Rotated Text"
With LOGFONT
.lfEscapement = -900
.lfOrientation = -900
.lfHeight = -ScaleY(Font.Size, vbPoints, vbPixels)
.lfWeight = IIf(Font.Bold, 700, Font.Weight)
.lfItalic = Font.Italic
.lfUnderline = Font.Underline
.lfStrikeOut = Font.Strikethrough
.lfCharSet = Font.Charset
.lfFaceName = Font.Name & vbNullChar
End With
hFont = CreateFontIndirect(VarPtr(LOGFONT))
hFontPrev = SelectObject(hDC, hFont)
SetTextColor hDC, vbYellow
TextOut hDC, _
ScaleX(ScaleWidth * 3 / 8, ScaleMode, vbPixels), _
ScaleY(ScaleHeight / 8, ScaleMode, vbPixels), _
StrPtr(Text), _
Len(Text)
'More, with opaque background:
Text = "More Rotated Text"
SetTextColor hDC, vbCyan
BkColorPrev = SetBkColor(hDC, vbBlue)
BkModePrev = SetBkMode(hDC, BM_OPAQUE)
TextOut hDC, ScaleX(ScaleWidth * 3 / 4, ScaleMode, vbPixels), 0, StrPtr(Text), Len(Text)
SetBkMode hDC, BkModePrev
SetBkColor hDC, BkColorPrev
'More, with original unrotated font:
Text = "More Plain Text"
SelectObject hDC, hFontPrev
DeleteObject hFont
SetTextColor hDC, vbGreen
TextOut hDC, _
ScaleX(ScaleWidth / 4, ScaleMode, vbPixels), _
ScaleY(ScaleHeight * 7 / 8, ScaleMode, vbPixels), _
StrPtr(Text), _
Len(Text)
'Use another rotated font:
Text = "abcde"
With LOGFONT
.lfEscapement = 450
.lfOrientation = 450
.lfHeight = -ScaleY(Font.Size * 1.75, vbPoints, vbPixels)
.lfWeight = 700
.lfCharSet = SYMBOL_CHARSET
.lfFaceName = "Wingdings" & vbNullChar
End With
hFont = CreateFontIndirect(VarPtr(LOGFONT))
hFontPrev = SelectObject(hDC, hFont)
SetTextColor hDC, vbRed
TextOut hDC, _
ScaleX(ScaleWidth / 32, ScaleMode, vbPixels), _
ScaleY(ScaleHeight * 7 / 8, ScaleMode, vbPixels), _
StrPtr(Text), _
Len(Text)
'Clean up:
SelectObject hDC, hFontPrev
DeleteObject hFont
SetTextColor hDC, TextColorPrev
End Sub
But perhaps I have misunderstood what you are after and so maybe this doesn't answer your questions.
You were using the ANSI calls which in VB6 results in translation to and then back from ANSI, wasting CPU time on two conversions.
Unicode (wide) calls don't waste that extra time and accept a broader range of characters, but you must explicitly pass pointers ByVal for a String or UDT argument. Using those types tells VB6 you want translation to and fro. This is a legacy of 16-bit VB.
The ancient ANSI calls left over from 16-bit Windows will work for this, but you must make sure your declarations match your intent.
This is covered in the VB6 documentation: "Accessing DLLs and the Windows API." Sadly those articles no longer seem to be online in these days of Microsoft's final decline. Look for this in your MSDN CD Docs.
You were using the ANSI calls which in VB6 results in translation to and then back from ANSI, wasting CPU time on two conversions.
Unicode (wide) calls don't waste that extra time and accept a broader range of characters, but you must explicitly pass pointers ByVal for a String or UDT argument. Using those types tells VB6 you want translation to and fro. This is a legacy of 16-bit VB.
The ancient ANSI calls left over from 16-bit Windows will work for this, but you must make sure your declarations match your intent.
This is covered in the VB6 documentation: "Accessing DLLs and the Windows API." Sadly those articles no longer seem to be online in these days of Microsoft's final decline. Look for this in your MSDN CD Docs.
I have tried under the topic and under Adresses in the content search section where they give some code, but none of it is comprehensible for me.
I do pass the parameters to that routine byval, but it does not help.
Here is my code:
Code:
Friend Sub PrintRotatedText(pic As PictureBox, ByVal Text As String, ByVal TextColour As Long, ByVal Xpos As Single, ByVal Ypos As Single, ByVal Angle As Long, FontSize As Integer, FontBold As Boolean, FontTransparent As Boolean, Optional FontWeight As Integer = 400, Optional FontItalic As Boolean = False, Optional FontUnderline As Boolean = False, Optional FontStrikeThrough As Boolean = False)
Dim TextColorPrev As Long
Dim LOGFONT As LOGFONT
Dim hFont As Long
Dim hFontPrev As Long
Dim BkColorPrev As Long
Dim BkModePrev As BkModes
'Use rotated font:
With LOGFONT
.lfEscapement = 10 * Angle
.lfOrientation = 10 * Angle
.lfHeight = -ScaleY(FontSize, vbPoints, vbPixels)
.lfWeight = IIf(FontBold, 700, FontWeight)
.lfItalic = FontItalic
.lfUnderline = FontUnderline
.lfStrikeOut = Font.Strikethrough
.lfCharSet = Charsets.ANSI_CHARSET
.lfFaceName = "Verdana" & vbNullChar
End With
hFont = CreateFontIndirect(VarPtr(LOGFONT))
hFontPrev = SelectObject(pic.hDC, hFont)
BkColorPrev = SetBkColor(pic.hDC, pic.BackColor)
BkModePrev = SetBkMode(pic.hDC, pic.FontTransparent)
TextColorPrev = pic.ForeColor
SetTextColor pic.hDC, TextColour
SetBkMode hDC, BM_TRANSPARENT
TextOut pic.hDC, pic.ScaleX(ScaleWidth * 3 / 8, picScaleMode, vbPixels), picScaleY(ScaleHeight / 8, pic.ScaleMode, vbPixels), StrPtr(Text), Len(Text)
SetBkMode hDC, BkModePrev
SetBkColor hDC, BkColorPrev
pic.ForeColor = TextColorPrev
'Clean up:
SelectObject hDC, hFontPrev
DeleteObject hFont
SetTextColor hDC, TextColorPrev
Exit Sub
End Sub
dilettante,
Still some teething problems, if you please.
Please look at my latest routine, which works without error, but:
1. I get Chinese characters.
2. The fontsize I pass to the routine is converted from vbPoints to vbPixels. Is a fontsize of 9, also 9 in vbPoints?
3. The position of the text is still wrong. I pass it in scale units. Is that right?
4. Why is the scalewidth multiplied by 3/8 and the scaleheight divided by 8 in the routine?
5. Is there any bug in the routine which you can see?
Code:
Friend Sub PrintRotatedText(pic As PictureBox, ByVal Text As String, ByVal TextColour As Long, ByVal Xpos As Single, ByVal Ypos As Single, ByVal Angle As Long, FontSize As Integer, FontBold As Boolean, FontTransparent As Boolean, Optional FontWeight As Integer = 400, Optional FontItalic As Boolean = False, Optional FontUnderline As Boolean = False, Optional FontStrikeThrough As Boolean = False)
Dim TextColorPrev As Long
Dim LOGFONT As LOGFONT
Dim hFont As Long
Dim hFontPrev As Long
Dim BkColorPrev As Long
Dim BkModePrev As BkModes
With LOGFONT
.lfEscapement = 10 * Angle
.lfOrientation = 10 * Angle
.lfHeight = -pic.ScaleY(FontSize, vbPoints, vbPixels)
.lfWeight = IIf(FontBold, 700, FontWeight)
.lfItalic = FontItalic
.lfUnderline = FontUnderline
.lfStrikeOut = Font.Strikethrough
.lfCharSet = Charsets.ANSI_CHARSET
.lfFaceName = "Verdana" & vbNullChar
End With
BkColorPrev = SetBkColor(pic.hDC, pic.BackColor)
BkModePrev = SetBkMode(pic.hDC, pic.FontTransparent)
TextColorPrev = pic.ForeColor
'Use current font w/o rotation:
If Angle = 0 Then
TextColorPrev = SetTextColor(hDC, vbBlack)
TextOut pic.hDC, 0, 0, StrPtr(Text), Len(Text)
Else
'Use rotated font:
hFont = CreateFontIndirect(VarPtr(LOGFONT))
hFontPrev = SelectObject(pic.hDC, hFont)
SetTextColor pic.hDC, TextColour
SetBkMode hDC, BM_TRANSPARENT
TextOut pic.hDC, pic.ScaleX(pic.ScaleWidth * 3 / 8, pic.ScaleMode, vbPixels), pic.ScaleY(pic.ScaleHeight / 8, pic.ScaleMode, vbPixels), StrPtr(Text), Len(Text)
End If
SetBkMode pic.hDC, BkModePrev
SetBkColor pic.hDC, BkColorPrev
pic.ForeColor = TextColorPrev
SelectObject pic.hDC, hFontPrev
DeleteObject hFont
SetTextColor pic.hDC, TextColorPrev
Exit Sub
End Sub
Thanks
PK
Last edited by Peekay; Apr 18th, 2021 at 03:30 AM.
Just in case you don't want to invest "another week" into that simple problem...
You have the RC5 (or even RC6) installed on your machine...
So, why don't you use its Drawing-Classes, to solve this problem with less code, via a modern drawing-lib (antialiased)?
Is it, because the cairo-Objects are "too virtual" (too abstract)?
... and that you "have to see something like a PictureBox" on your Form first?
However, maybe the following code can help you with that first step -
ensuring "a PictureBox-like Cairo-Canvas-Setup" on a given VB-ParentForm...
Code:
Option Explicit
Private PB As cCairoContext
Private Sub Form_Load()
Set PB = Cairo.CreateSurface(200, 200).CreateContext '<- define the size of your "PicBox" here
Me.Caption = "Form contains a cairo-PicBox with " & PB.Surface.Width & "x" & PB.Surface.Height & " Pixels"
End Sub
Private Sub Form_Resize()
RefreshPBAtOffs 20, 20 '<- define the placement-offsets of the cairo-PicBox on the Form
End Sub
Public Sub RefreshPBAtOffs(xPxl, yPxl)
Me.AutoRedraw = True: Cls
PB.Paint 1, Cairo.CreateSolidPatternLng(vbWhite) 'clear the BackGround (currently in white)
PB_Paint 'here we call a Sub-routine, named similar to a PicBox_Paint-EventHandler
PB.Surface.DrawToDC Me.hDC, xPxl, yPxl 'reflect the PB-contents on the Form.hDC
Me.Refresh
End Sub
Private Sub PB_Paint() 'here you can now finally place your own drawing-calls, using the PB-Object
'...
End Sub
The above code will produce a "PictureBox-like area having a white Background" (on an otherwise empty Form)
Ok, the above is "generic" - and could be copied as a "starting-setup, as is",
onto any other empty Form, where you might need such a PicBox-like cairo-Canvas-area.
As for concrete Drawing-Code (to be placed in the Event-like "PB_Paint()" routine) -
perhaps we should start with drawing "simple lines" ... though (judging from your recent Map-threads) -
we should probably define a small wrapper-routine, which accepts PolarCoords (cx, cy, AngleDeg, Length, ...).
Code:
Sub DrawLinePolar(ByVal cx#, ByVal cy#, ByVal AngleDeg#, ByVal Length#, Optional ByVal LineColor&, Optional ByVal LineWidth# = 2)
PB.Save: PB.TranslateDrawings cx, cy: PB.RotateDrawingsDeg AngleDeg 'save, and transform to PolarCoord-mode
PB.DrawLine 0, 0, Abs(Length), 0, False, LineWidth, LineColor
PB.Restore 'restore the previous coord-sys upon return from this routine
End Sub
After defining the above DrawLinePolar()-helper, we can now use it within the "Paint-Event" this way:
Code:
Private Sub PB_Paint() 'here you can now finally place your own drawing-calls
DrawLinePolar 15, 70, -30, 90, vbBlue, 3
DrawLinePolar 55, 100, 0, 90, vbCyan, 2
DrawLinePolar 100, 130, 30, 90, vbGreen, 1
End Sub
Now producing this output on your white PB-area on the Form...
(3 lines, having Line-Widths: 3, 2 and 1...)
Ok, now to the TextOutput ... why not define a second helper-routine,
which accepts the same first 4 "Polar-Coord-arguments" as the LineDrawing-Helper?
Code:
Sub DrawTextPolar(ByVal cx#, ByVal cy#, ByVal AngleDeg#, ByVal Length#, Text$, Optional ByVal TextColor&, Optional ByVal Align As AlignmentConstants, Optional ByVal BaseLineDistance#, Optional ByVal FontName$ = "Arial", Optional ByVal FontSize# = 10, Optional ByVal FontBold&, Optional ByVal FontItalic&)
PB.Save: PB.TranslateDrawings cx, cy: PB.RotateDrawingsDeg AngleDeg 'save, and transform to PolarCoord-mode
PB.SelectFont FontName, FontSize, , FontBold, FontItalic 'first select the current font...
Dim TX#, TW#: TW = PB.GetTextExtents(Text) 'so that we get the right TextWidth-measurement
Select Case Align
Case vbCenter: TX = (Abs(Length) - TW) / 2
Case vbRightJustify: TX = (Abs(Length) - TW)
End Select
PB.TranslateDrawings TX, -BaseLineDistance 'x-alignment + slight "uplifting" of the text relative to the BaseLine
PB.TextOut 0, 0, Text, True, 1, True
PB.Fill , Cairo.CreateSolidPatternLng(TextColor)
PB.Restore 'restore the previous coord-sys upon return from this routine
End Sub
Ok, and the adjusted Paint-Event-like routine again, which makes use of that new Helper-Sub:
Code:
Private Sub PB_Paint() 'here you can now finally place your own drawing-calls
DrawLinePolar 15, 70, -30, 90, vbBlue, 3
DrawTextPolar 15, 70, -30, 90, "Left aligned", vbRed, vbLeftJustify, 3 / 2 + 1
DrawLinePolar 55, 100, 0, 90, vbCyan, 2
DrawTextPolar 55, 100, 0, 90, "Centered", vbBlack, vbCenter, 2 / 2 + 1
DrawLinePolar 100, 130, 30, 90, vbGreen, 1
DrawTextPolar 100, 130, 30, 90, "Right aligned", vbMagenta, vbRightJustify, 1 / 2 + 1
End Sub
So, the polar Text-Outputs will "follow" the polar Line-Outputs exactly -
(since they got passed the same first 4 arguments) - and will now produce this:
I have downloaded RC6 and registered it in place.
I have placed the RC6 in my Project References.
I have 'Public pb As cCairoContext' in my module where I declare public variables.
I have 'Set pb = Cairo.CreateSurface(200, 200).CreateContext' in my Form_Load routine.
When it comes to the latter is says: 'Invalid use of property'
...I do not know it well and I do not have a manual to guide me.
That's not really true.
The RC5/RC6 vector-drawing-classes do follow the original cairo-API quite well (you even get Intellisense-Popups) -
therefore you can google easily for the original cairo-API - e.g. with regards to "transforms" (translate, rotate, scale): https://developer.gnome.org/cairo/st...airo-translate
This explains in normal english, what the underlying routines will do to your current coord-system.
No other drawing-lib for VB6 has this kind of coverage (e.g. the above mentioned "transforms" are explained in "Folder #2").
Originally Posted by Peekay
...you always spend so much time helping me...
That's because I know, that you will not be able to solve your current problem of:
"drawing advanced stuff properly onto a shiftable, zoomable google-map-background image"
in a stable, visually satisfying manner without using "Transforms and the related, underlying Transform-Matrices".
If I make a guess, you have probably invested *at most* half a day into "learning cairo" -
that's not enough by far... but as I see it, you have "invested" the last 2 weeks on:
- "trying to solve stitching" (via GDI or PaintPicture)
- "trying to solve rotated Text" (via GDI)
I can assure you, that after studying cairo "only half the time" (for just 1 week),
the above two points won't have come up as "a problem" at all.
Despite that ... dilettante said it right: "we live in the days of Microsoft's final decline" -
and that's "just another reason" why I think, "learning a platform-independent drawing-lib" == "time, well-invested".
Now that the twinBasic-compiler came-up out of nowhere (making good progress)...:
- RC5/RC6-based VB6-code-snippets *will* work (also) on Linux, unchanged
- whereas GDI-based VB6-code-snippets (relying on a ton of Windows-specific API-declares), will not
I have 'Public pb As cCairoContext' in my module where I declare public variables.
Please leave this Variable "PB" Privately declared at the Level of the Form it will then "act-on" as a PicBox-replacement.
Otherwise, your err-message hints at a "not properly registered RC6".
JFYI, RC6 will only work (and register) on machines > Vista (Win7 and up) -
it will not work on XP ... if you're still on XP, then use the RC5 instead (the example should work with it as well).
Perhaps you should check the following things:
- close all IDE-instances which might have a reference to RC6
- make sure, you didn't already have another RC6-version somewhere (in a different Folder)
- if yes, unregister it there (on an admin-console) via: regsvr32 /u c:\your\path\to\RC6.dll
And as for the Folder of your last RC6-install attempt:
- make sure, all the Dlls of the RC6BaseDll-package are located there (beside each other)
- then try to register it again there (on an admin-console) via: regsvr32 c:\your\path\to\RC6.dll
Now you should be able to reference (and use) it in a new Project.
I presume I need a picture box in which to render/display it then, or do I not understand it correctly.
No, my intent with the code (as posted in #19) was, to give you a replacement for a PictureBox (on an empty Form).
If you want to render within the confines of a "real VB6-PictureBox" instead:
- you should define one on your Form of course (but named different from "PB")
- e.g. if you named this PicBox as: picCanvas, then the following "setup-code" should work
Code:
Option Explicit
Private PB As cCairoContext
Private Sub Form_Load()
InitCairoContextOnVB6PicBox picCanvas, PB '<- sync to the size of your PicBox here
Me.Caption = "Form contains a cairo-PicBox with " & PB.Surface.Width & "x" & PB.Surface.Height & " Pixels"
End Sub
Sub InitCairoContextOnVB6PicBox(picBox As VB.PictureBox, PB As cCairoContext)
picBox.ScaleMode = vbPixels
Set PB = Cairo.CreateSurface(picBox.ScaleWidth, picBox.ScaleHeight).CreateContext
RefreshPB
End Sub
Private Sub picCanvas_Resize()
InitCairoContextOnVB6PicBox picCanvas, PB
End Sub
Sub RefreshPB()
picCanvas.AutoRedraw = True: picCanvas.Cls
PB.Paint 1, Cairo.CreateSolidPatternLng(vbWhite) 'clear the BackGround (currently in white)
PB_Paint 'here we call a Sub-routine, named similar to a PicBox_Paint-EventHandler
PB.Surface.DrawToDC picCanvas.hDC 'reflect the PB-contents on the picCanvas.hDC
picCanvas.Refresh
End Sub
The rest of the Code (PB_Paint(), as well as the two helper-routines) can remain as they were...
HTH
Olaf
Edit: FWIW - below the complete example again "en bloc" - mapped to a real VB.PictureBox, named picCanvas
(at this occasion, I've renamed "PB As cCairoContext" to "Canvas As cCairoContext" to match better with picCanvas)
Code:
Option Explicit
Private Canvas As cCairoContext 'Canvas will be "size-synced" and rendered in picCanvas (a VB.PictureBox)
Private Sub Form_Load()
InitCairoContextOnVB6PicBox picCanvas, Canvas '<- sync to the size of your PicBox here
Me.Caption = "Form contains a cairo-PicBox with " & Canvas.Surface.Width & "x" & Canvas.Surface.Height & " Pixels"
End Sub
Sub InitCairoContextOnVB6PicBox(picBox As VB.PictureBox, Canvas As cCairoContext)
picBox.ScaleMode = vbPixels
Set Canvas = Cairo.CreateSurface(picBox.ScaleWidth, picBox.ScaleHeight).CreateContext
RefreshCanvas
End Sub
Private Sub picCanvas_Resize()
InitCairoContextOnVB6PicBox picCanvas, Canvas
End Sub
Sub RefreshCanvas()
picCanvas.AutoRedraw = True: picCanvas.Cls
Canvas.Paint 1, Cairo.CreateSolidPatternLng(vbWhite) 'clear the BackGround (currently in white)
Canvas_Paint 'here we call a Sub-routine, named similar to a PicBox_Paint-EventHandler
Canvas.Surface.DrawToDC picCanvas.hDC 'reflect the Canvas-contents on the picCanvas.hDC
picCanvas.Refresh
End Sub
Private Sub Canvas_Paint() 'here you can now finally place your own drawing-calls
DrawLinePolar 15, 70, -30, 90, vbBlue, 3
DrawTextPolar 15, 70, -30, 90, "Left aligned", vbRed, vbLeftJustify, 3 / 2 + 1.5
DrawLinePolar 55, 100, 0, 90, vbCyan, 2
DrawTextPolar 55, 100, 0, 90, "Centered", vbBlack, vbCenter, 2 / 2 + 1.5
DrawLinePolar 100, 130, 30, 90, vbGreen, 1
DrawTextPolar 100, 130, 30, 90, "Right aligned", vbMagenta, vbRightJustify, 1 / 2 + 1.5
End Sub
Sub DrawLinePolar(ByVal cx#, ByVal cy#, ByVal AngleDeg#, ByVal Length#, Optional ByVal LineColor&, Optional ByVal LineWidth# = 2)
Canvas.Save: Canvas.TranslateDrawings cx, cy: Canvas.RotateDrawingsDeg AngleDeg 'save, and transform to PolarCoord-mode
Canvas.DrawLine 0, 0, Abs(Length), 0, False, LineWidth, LineColor
Canvas.Restore 'restore the previous coord-sys upon return from this routine
End Sub
Sub DrawTextPolar(ByVal cx#, ByVal cy#, ByVal AngleDeg#, ByVal Length#, Text$, Optional ByVal TextColor&, Optional ByVal Align As AlignmentConstants, Optional ByVal BaseLineDistance#, Optional ByVal FontName$ = "Arial", Optional ByVal FontSize# = 10, Optional ByVal FontBold&, Optional ByVal FontItalic&)
Canvas.Save: Canvas.TranslateDrawings cx, cy: Canvas.RotateDrawingsDeg AngleDeg 'save, and transform to PolarCoord-mode
Canvas.SelectFont FontName, FontSize, , FontBold, FontItalic 'first select the current font...
Dim TX#, TW#: TW = Canvas.GetTextExtents(Text) 'so that we get the right TextWidth-measurement
Select Case Align
Case vbCenter: TX = (Abs(Length) - TW) / 2
Case vbRightJustify: TX = (Abs(Length) - TW)
End Select
Canvas.TranslateDrawings TX, -BaseLineDistance 'x-alignment + slight "uplifting" of the text relative to the BaseLine
Canvas.TextOut 0, 0, Text, True, 1, True
Canvas.Fill , Cairo.CreateSolidPatternLng(TextColor)
Canvas.Restore 'restore the previous coord-sys upon return from this routine
End Sub
Last edited by Schmidt; Apr 18th, 2021 at 06:42 AM.
I modified the example from post # 12. declarations and variables left the same. Added 3 variables. Form, PictureBox and two buttons:
Code:
Dim X1 As Integer
Dim Y1 As Integer
Dim Angle As Integer
Private Sub Command1_Click() '(+)
Picture1.Cls
Angle = Angle + 10
Draw
End Sub
Private Sub Command2_Click() '(-)
Picture1.Cls
Angle = Angle - 10
Draw
End Sub
Private Sub Form_Load()
Picture1.ScaleMode = 3
Picture1.AutoRedraw = True
Text = "Rotated text"
X1 = 0
Y1 = Picture1.ScaleHeight - Font.Size * 2
Angle = 450
With LOGFONT
.lfEscapement = Angle
.lfOrientation = 0
.lfHeight = -ScaleY(Font.Size * 1.75, vbPoints, vbPixels)
.lfWeight = 700
.lfCharSet = ANSI_CHARSET
.lfFaceName = "Wingdings" & vbNullChar
End With
Draw
End Sub
Private Sub Draw()
LOGFONT.lfEscapement = Angle
hFont = CreateFontIndirect(VarPtr(LOGFONT))
hFontPrev = SelectObject(Picture1.hDC, hFont)
SetTextColor Picture1.hDC, vbRed
TextOut Picture1.hDC, X1, Y1, _
StrPtr(Text), _
Len(Text)
'Clean up:
SelectObject Picture1.hDC, hFontPrev
DeleteObject hFont
SetTextColor Picture1.hDC, TextColorPrev
End Sub
The text rotates when buttons are pressed. For normal operation, you need to add tracking of the origin of coordinates, text output depending on the rotation angle and set traps when the borders of the PictureBox are reached.
Argus19,
Thank you for your contribution. I always welcome diverse opinions so that the thread can be insightful for all users in future. It is not only for my edification and enlightenment on the subject. I know contributors like those who contributed here do it for the benefit of the whole forum.
PK
I wish we had another answer to Microsoft's self-imposed decline, but sadly Windows remains the only OS that matters. Desktop Linux basically doesn't exist:
Well, and for as long as it does -
VB6/VBA or twinBasic-Users can handle advanced graphics with a decent Class-wrapper for Cairo...
The "other OSes" (no matter what they are) usually offer a C-compiler (or LLVM-support)
which in turn means, that precompiled cairo-binaries either already exist, or can be made available there.
In a few years, we will be able, to compile and run VB6-sources (with GUI) directly on a Raspberry-Pi -
but also on Android - not really negligible, if you ask me.
Besides, for WebApp-scenarios, I'd also like to be able to run my VB6-sources on a cheaper Linux-Host-installation,
replacing the usual "LAMP" (Linux, Apache, MySQL, PHP/Python) with "LNST" (Linux, Node, SQLite, TwinBasic).
Currently (at the place where I work), we need to rent twice as expensive Windows-Hosts -
(which currently run IIS+Node+WinAx+VB6-COM-Dlls, to serve requests).
The text display cannot be seen clearly on the background image. How to display luminous text or white font with black stroke, and how to set the stroke thickness?