Mustaphi,
which 1.8 version do you have ? (revision)
Printable View
Mustaphi,
which 1.8 version do you have ? (revision)
version 1.8.27Quote:
Originally Posted by Krool
https://www.vbforums.com/showthread....55#post5129155
I've the same problem, I try with the ocx and with the exe version. And, also, when I put a file jpg as picture in design time, this is not displayed, either at design time or at run time.
Would be a problem with the OS version or VB6 version?
Internal improvement for the ToolBar control.
There are no redraw/refresh issues anymore on design time. (IDE)
Also some code optimization to increase performance.
Also adjustment for CoolBar concerning child sizes.
Some childs, e.g. ToolBar, re-size itself.
The CoolBar adjusted in the past when the child size increased, now it adjusts also when it decreases. (But CY must be > 0 for the child to avoid false adjustment)
I didn't update change log, falls all under the recent internal improvement.
Info: the reactos toolbar.c source helped a lot solving some last edge cases and be more straight forward in the quirks.
Update: MaxTextRows property is now allowed to be set to 0 in the ToolBar control.
I noticed that MSCOMCTL had an enum defined called ClipboardConstants which VBCCR (1.7) does not seem to include. IDL definition from MSCOMCTL pasted below.
While it would be nice if this were in VBCCR, I'm sure there was a good reason to omit it. Probably nothing else in the same library utilizes it. (It is similarly not referenced anywhere in the MSCOMCTL IDL).
Are there any recommendations for a suitable replacement? Obviously I can define my own enum with the same values but if there is a pre-existing standard place [e.g, DLL] to get it from that would be better.
Thanks!
Code:typedef [uuid(D8898462-742F-11CF-8AEA-00AA00C00905), helpstring("Clipboard format constants."), helpcontext(0x00033681)]
enum {
ccCFText = 1,
ccCFBitmap = 2,
ccCFMetafile = 3,
ccCFDIB = 8,
ccCFPalette = 9,
ccCFEMetafile = 14,
ccCFFiles = 15,
ccCFRTF = -16639
} ClipBoardConstants;
From MSDN:
Code:Constant Value Description
vbCFRTF -16639 Rich Text Format (.rtf file)
vbCFLink -16640 DDE conversation information
vbCFText 1 Text (.txt file)
vbCFBitmap 2 Bitmap (.bmp file)
vbCFMetafile 3 Metafile (.wmf file)
vbCFDIB 8 Device-independent bitmap
vbCFPalette 9 Color palette
vbCFEMetaFile 14 Enhanced metafile (.emf file)
vbCFFiles 15 File list from Windows Explorer
Update released.
The height of the header will now be adjusted according to ColumnHeaderIcons in the ListView control.
This is the same behavior as for the original MS ListView control for VB6. An ImageList of 32x32 will therefore increase the header portion.
To note is that when VisualStyles are set or HDS_FLAT is set there is no extra spacing added as not necessary.
Else the spacing (2x SM_CYEDGE) is added for the classic edges so that the icon better fits. (and to match MS ListView behavior)
When HDS_FILTERBAR is set the header must be set x2. So, for an 32x32 icon the size is treated as 64px.
Update released.
Internal improvement for the ImplementThemedReBarFix for the CoolBar control. (usage of GetThemePartSize)
Update released.
Internal improvement in the DrawPanel method for the StatusBar control.
For the center alignment there was a minor calc. bug when a picture is set and for higher dpi's it matches now 100% as a non-ownerdraw statusbar would display.
Also there was 1px offset in the Y pos of the text output vs. non-ownerdraw statusbar.
Also the internal GetGoodWidth function for auto-size is adjusted to these fixes.
Deleted, Krool responded with good answer in the Q&A section of these forums.
Update released.
Bugfix that the Text property was not the default property in the SbrPanel object.
Included the PictureOnRight property of a Panel in the StatusBar control.
I needed to edit the type lib for SbrPanel anyway in the VBCCR18.OCX. Thus the new PictureOnRight property is also included. (similar to IconOnRight in LvwColumnHeader)
The Picture of a Panel will now be drawn embossed when the Enabled property is False in the StatusBar control.
Also the grayed text is now drawn using TextOut instead of DrawState for standard VB-ish appearance.
Bug in the internal ReCreateToolBar method that the button menus picture property was not restored.
Maybe it is already known, but I did not :
In this case, ImageCombo1 will not be empty whereas ImageCombo2 will. (only tested in the IDE).Code:Private Sub Form_Load()
ImageCombo1.Text = vbNullString
ImageCombo2.Text = ""
End Sub
Thanks. No it was not aware, will fix soon at next oppurtunity.Quote:
Originally Posted by Crapahute
It seems like the ComboBoxEx class doesn't like a null pointer.
EDIT: Fixed. Thx
Update released.
Bugfix in the ListBoxW when Style is 1 - Checkbox or 2 - Option at higher DPI.
The old code for the checkbox or optionbutton image was:
However, at some DPI's it was wrong. The new code is:Code:ListBoxStateImageSize = (15 * PixelsPerDIP_X())
The padding is always fixed at 2. (for hit-testing/item height etc. the 2 × 1px space padding is important)Code:ListBoxStateImageSize = (13 * PixelsPerDIP_X()) + 2
The actual image is then drawn without this padding. (then effectively ListBoxStateImageSize - 2)
Ok... feeling stupid here. Most of the controls seem to work well but a few give an error when added to a form:
The X control requires at least version 6.0 of comctl32.dll
Now it wants me to make a manifest for my project. Bit lost here. Can somebody explain it to me like I'm 5... what am I supposed to do to make a manifest for version 6.0 of comctl32.dll?
CommonControls (Replacement of the MS common controls)-VBForums
?I hope this control can also achieve full transparency.?
https://www.vbforums.com/showthread....ntrol-supports
On the treeview control, when there is images next to the check boxes there is no padding like there is with the text after the image.
Is there a way to change the padding from the checkbox before the image? Possibly even the padding between nodes?
Attachment 193151
Another problem I have ran into. Listview with groups. When you have a large number of groups, doing anything with the group header or looping through the groups slows down to a crawl.
Example, Have 19,000 groups 57000 items. Everything loads up nice and fast.
But loop through the groups for anything is a huge slow down, like looping through the groups to get the item count and update the group header to show have many items are in the group.
Also looping through the groups to set the checkbox on everything except the first item in the group.
When testing with say 150 groups there is no problem. I'm not sure what the number is on the groups to cause such a slow down. Not sure why simply looping through a high number of groups is so slow.
Here is an code example
Then an example of selecting everything in a group except the first itemCode:i = 0
lListTotal = 0
DoEvents
lListTotal = ListViewDupFiles.Groups.count
If Not lListTotal = 0 Then
For i = 1 To lListTotal
ListViewDupFiles.Groups(i).Header = ListViewDupFiles.Groups(i).Header & " (File Count: " & ListViewDupFiles.Groups(i).ListItemIndices.count & ")"
DoEvents
Next i
End If
Edit: I will do some testing and see if the problem is looping through a high number of groups or if the slow down is in calling the ListItemIndices on such a high number of groups.Code:Dim i As Long
Dim i2 As Long
Dim lListTotal As Long
Dim lListTotal2 As Long
i = 0
lListTotal = 0
DoEvents
lListTotal = ListViewDupFiles.Groups.count
If Not lListTotal = 0 Then
For i = 1 To lListTotal
i2 = 0
lListTotal2 = 0
DoEvents
lListTotal2 = ListViewDupFiles.Groups(i).ListItemIndices.count
For i2 = lListTotal2 To 2 Step -1
ListViewDupFiles.ListItems.Item(ListViewDupFiles.Groups(i).ListItemIndices(i2)).Checked = True
DoEvents
Next
ListViewDupFiles.ListItems.Item(ListViewDupFiles.Groups(i).ListItemIndices(1)).Checked = False
DoEvents
Next i
End If
DoEvents
Edit2: Diffidently doing anything with the groups. Next code example is just looping through each group header and updating it.
Code:Dim i As Long
Dim i2 As Long
Dim lListTotal As Long
Dim lListTotal2 As Long
i = 0
lListTotal = 0
DoEvents
lListTotal = ListViewDupFiles.Groups.count
If Not lListTotal = 0 Then
For i = 1 To lListTotal
ListViewDupFiles.Groups(i).Header = ListViewDupFiles.Groups(i).Header & " - Done!"
DoEvents
Next i
End If
DoEvents
SMC1979,
Try a "For Each" loop with the groups. That's faster than accessing the collection by index.
Just tried that. Same slow down, updates the group at about 1 group per second. Again only when there is a TON of groups such as 19000. When I test with say 150 groups its nearly instant.
I was able to get past the selecting everything in a group except the first one by putting a tag on that list item and then I just loop through all the items like normal putting the check box on while skipping any with the tag set. On the 57000 items that takes about 3 or 4 sec.
For some reason once the groups have been created they are very slow to loop through.
I will do a test now where I will just loop through the groups and have it simply add to counter, no changing anything of the group and see the speed it does. That way I can tell if it is the looping that is slow.
Code:Dim gGroup As LvwGroup
For Each gGroup In ListViewDupFiles.Groups
gGroup.Header = gGroup.Header & " - " & gGroup.ListItemIndices.count
DoEvents
Next
OK just doing a simple loop was fast, 19000 groups took about 3 or 4 sec to count.
So for some reason reading the ListItemIndices or changing the header is what is slow when there is a ton of groups.
For now I will just have to skip changing the header to include the count.
Code:Dim gGroup As LvwGroup
Dim i As Long
i = 0
For Each gGroup In ListViewDupFiles.Groups
i = i + 1
Label1.Caption = i
DoEvents
Next
If you have tens of thousands to millions of data, you set it to the virtual table mode.Your data is only placed in the array, and the control does not participate in the processing.The size of the space determines how many rows it displays, for example, s rows, from which it will extract only the 20 rows of data it needs.Quote:
Originally Posted by SMC1979
So when you have 10,000 data and 10 million data, the speed is almost the same.
The Aug 14th, 2014, 06:24 PM:
https://www.vbforums.com/showthread....ntrols)/page12
Sorry Kroll, this message is the 10 years ago...Quote:
Originally Posted by Krool
If you can tell me, did you find any problem in making it transparent or allowing a background image to be put on it, features that can be interesting at certain times, or I can try to modify the OCX so that it does so...
Well, if after 10 years the control still cannot be made transparent, it may not be possible, and in that case I won't waste time trying, Because I have to finish a program for my company and I am short on time...
If you have time and want to answer me, of course...
Thanks in advance... Greetings!!!
I've done a little hack and it works for me, since I don't really want a RichTextBox, but a Label with full unicode support and SetAligment = 3 (Justified Text) and that I can put a background image on.
I already have it by adding a PictureBox to the Krool Usercontrol, and:
SetWindowLong RichtextBox1.hwnd, GWL_EXSTYLE, WS_EX_TRANSPARENT
(I'll set it internally later)
I don't know why the Krool usercontrol doesn't support Picture properties, do error when a Property is Picture and in code write RichTextBox1.Picture = LoadPicture(Path), but I've put a String property that is the Path of the Image that I want to load and there I do internally the Picture1.Picture = LoadPicture(String Path), I have to implement capturing what is behind the usercontrol as the 2nd option...
But it doesn't work like a RichTextBox, but rather like a Label, it's not really transparent, but by capturing the image behind the control I can pass the Background to the RichTextBox... But it can be implemented so that if you don't want a Picture, it behaves like a Krool RichTextBox Control...
When I have it polished, I'll put it here in case anyone is interested, but it's like a Label with a Background Image, which could be like transparent capturing what is behind the Control, and the Complete Unicode and Justified Text properties with the Margins...
https://www.vbforums.com/showthread....ntrol-supportsQuote:
Originally Posted by James Reynolds
With this method, I can copy the background behind each space.It can be done with only one line of code.
If there are multiple controls behind it, it's like true transparency.
If your space is constantly moving, it can also achieve a transparent effect.
Thanks xiaoyao, well, a question, I need to use in the VB6 ide?Quote:
Originally Posted by xiaoyao
I'm already completing the RichTextcontrol and it works fine, and it will work as a complete RichTextBox, I have removed the Picture, and I load the Picture in Usercontrol.Picture, and if you do "ImagePath = valid path image", convert to transparent the richTextBoxHandle, and loads the Image in UserControl.Picture, if you do ImagePath = "" the transparency is removed and it works as it is in the original RichTextBox of Krool, without a background Image.
I create this Property:
Now I need to capture what is under the RichTextBox, add a property that tells the RichTextBox from Krool to make it transparent by capturing what is under the RichTextBox, but I want that process to be internal in the RichTextBox usercontrol itself... I'll look at your code there xiaoyao!!!Code:Public Property Get ImagePath() As String
ImagePath = m_ImagePath
End Property
Public Property Let ImagePath(ByVal newPath As String)
If newPath = "" Then
Set UserControl.Picture = Nothing
RemoveTransparency
PropertyChanged "ImagePath"
UserControl.Refresh
ElseIf Dir(newPath) <> "" Then
m_ImagePath = newPath
SetWindowLong richTextBoxHandle, GWL_EXSTYLE, WS_EX_TRANSPARENT
' Load the image to the UserControl
Set UserControl.Picture = LoadPicture(m_ImagePath)
PropertyChanged "ImagePath"
UserControl.Refresh
Else
MsgBox "The image is not found at the specified path.", vbExclamation
End If
End Property
Public Sub RemoveTransparency()
Dim currentStyle As Long
currentStyle = GetWindowLong(richTextBoxHandle, GWL_EXSTYLE)
currentStyle = currentStyle And Not WS_EX_TRANSPARENT
SetWindowLong richTextBoxHandle, GWL_EXSTYLE, currentStyle
End Sub
Then I have to add some Stretch or Autosize property to the Image.
But it's being easier than I thought... And it's going to have all the functionality of the Krool RichTextBox, I think, I still need to test it thoroughly...
Sadly, Group view doesn't work in virtual mode.Quote:
Originally Posted by xiaoyao
Sub TransparentWithHdc(MyHwnd As Long, MyHdc As Long)Quote:
Originally Posted by James Reynolds
If MyHdc = 0 Or MyHwnd = 0 Then MsgBox "Need CONTROL WITH HWND / HDC VALUE"
UserControl.HDC,UserControl.HWND
YOU ONLY NEED SET UserControl.AUTOREDRAW=TRUE
code in UserControl.ctl
call on form1:Code:Private Sub UserControl_Initialize()
UserControl.AutoRedraw = True
End Sub
Sub Transparent_Me()
TransparentWithHdc UserControl.hwnd, UserControl.Hdc
End Sub
Code:Private Sub Form_Load()
Me.Picture = LoadPicture("img.jpg")
End Sub
Private Sub Command1_Click()
UserControl11.Transparent_Me
End Sub
'FOR MOVE CONTROL
Private Sub Command2_Click()
UserControl11.Left = UserControl11.Left + UserControl11.Width / 2
UserControl11.Transparent_Me
End Sub
Ok xiaoyao, thanks, but I solutioned internally in the RichTextBox... Capturing the HDC of the container of the Krool RichTextBox...Quote:
Originally Posted by xiaoyao
Another question, in RichTextBox of Krool are any property for know the TextHeight for a given width?
The MDI_ToolBar demo now uses WH_GETMESSAGE instead of WH_KEYBOARD_LL hook to avoid beep on alt key press.
Check out the EM_FORMATRANGE message and the FORMATRANGE structure. If you set the bounds of your target rectangle but use &H7FFFFFFF for the rc.Bottom property value and send the EM_FORMATRANGE to the RTB with a wParam of 0 (to just measure, not render) then the rc.Bottom will be set to the height of the formatted text in twips. If the .Bottom value remains at &H7FFFFFFF then you should assume a height of 0 twips.Quote:
Originally Posted by James Reynolds
Don't forget to cleanup when you are done by sending a second EM_FORMATRANGE message with wParam and lParam set to 0.
The text box you designed can not set the margin. Like two pixels or eight pixels.
Can text be centered vertically?
Suppose the text box is 200 pixels high and the margins are set to two pixels. So the text should be set to 196 pixels.
This is how to set auto height and auto width. Adapt according to the size of the space or the size of the text?
autofill
Or auto-crop to make the control smaller.
Thanks again jpbro, but uhmm, could you give me a little bit of the code, or don't you have it at hand...?Quote:
Originally Posted by jpbro
On the other hand, I think that the control itself should have 2 properties, textWidth and textHeight, to know how much the text takes up in many situations, like, for example, I'm going to use it to have full Unicode in a Tooltip and justified with de margins, with this way it will look very perfect to the eye, and there I need to know the width and height of the text, because in a ToolTip there can't be scroll bars...
Greetings jpbro, if you have the code at hand, if not, don't waste your time... Greetings to you and to everyone...
Update released
Concerning the recent MDI_ToolBar demo change to use WH_GETMESSAGE instead of WH_KEYBOARD_LL hook to avoid the beeps on alt key press. (the beep was only when a modal popup drop-down menu is shown)
In this regard I did also now a bugfix in the .ContainerKeyDown function in the ToolBar control.
The function will now return Nothing when a popup menu is already present.
It checks first, if it's own popup menu is present. (ToolBarPopupMenuHandle <> NULL_PTR)
But in addition it checks whether an application popup menu (form menu, context menu etc.) is also shown. And when a popup menu is shown .ContainerKeyDown will return Nothing to intentionally cause a beep.
For this the code from https://stackoverflow.com/questions/...ny-menu-opened was useful.
I adopted it as following to be more efficient and faster:
Code:If EnumThreadWindows(App.ThreadID, AddressOf ComCtlsTbrEnumThreadWndProc, 0) = 0 Then ' Menu is present
Code:Public Function ComCtlsTbrEnumThreadWndProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
If GetClassLong(hWnd, GCW_ATOM) = &H8000& Then ComCtlsTbrEnumThreadWndProc = 0 Else ComCtlsTbrEnumThreadWndProc = 1
End Function
Ok jpbro, I've fixed it, with chatGPT, it's a bit messy in Krool's richtextBox, but I've fixed it, apparently, with this:Quote:
Originally Posted by jpbro
I don't know if the CalculateTargetWidth function is correct, I got a bit confused with RichTextBoxEnabledVisualStyles...Code:'To avoid creating interference with the Krool Types
Private Type CHARRANGE_HEIGHT
cpMin As Long
cpMax As Long
End Type
Private Type FORMATRANGE_HEIGHT
hdc As Long
hdcTarget As Long
rc As RECT
rcPage As RECT
chrg As CHARRANGE_HEIGHT
End Type
Public Property Get TextHeight() As Long
TextHeight = GetRichTextHeight(richTextBoxHandle)
End Property
Public Function GetRichTextHeight(richTextBoxHwnd As Long) As Long
Dim fr As FORMATRANGE_HEIGHT
Dim rc As RECT
Dim rcPage As RECT
Dim charRange As CHARRANGE_HEIGHT
Dim result As Long
Dim targetWidth As Long
targetWidth = CalculateTargetWidth()
' Set the range of characters to measure (all text)
charRange.cpMin = 0
charRange.cpMax = -1
' Set the RECT to define the width of the target area and a very large height
rc.Left = 0
rc.Top = 0
rc.Right = targetWidth
rc.Bottom = &H7FFFFFFF ' High value to get the necessary height
' Set the RECT of the page
rcPage = rc
' Fill the FORMATRANGE_HEIGHT structure
fr.hdc = GetDC(richTextBoxHwnd) ' Get the RichTextBox device context
fr.hdcTarget = fr.hdc ' The context of the target device (same in this case)
fr.rc = rc
fr.rcPage = rcPage
fr.chrg = charRange
' Send the EM_FORMATRANGE message to measure the text
result = SendMessage(richTextBoxHwnd, EM_FORMATRANGE, 0, fr)
' Release the device context
ReleaseDC richTextBoxHwnd, fr.hdc
' Clean up after measuring
SendMessage richTextBoxHwnd, EM_FORMATRANGE, 0, ByVal 0&
' Return the height in twips
GetRichTextHeight = result
End Function
Private Function CalculateTargetWidth() As Long
Dim borderWidthTwips As Long
Dim BorderX As Long, BorderY As Long
Const SM_CXEDGE As Long = 45
Const SM_CYEDGE As Long = 46
' Get the border width dynamically based on system settings
BorderX = GetSystemMetrics(SM_CXEDGE)
BorderY = GetSystemMetrics(SM_CYEDGE)
' Determine the border width based on current properties
If PropBorderStyle = vbFixedSingle Then
If PropVisualStyles = True And RichTextBoxEnabledVisualStyles = True Then
' Visual style enabled, border could be thicker
borderWidthTwips = 2 * BorderX
Else
' Classic style, 1 pixel border on each side
borderWidthTwips = 1 * BorderX
End If
Else
' Without border
borderWidthTwips = 0
End If
' Calculate the target width for the text
CalculateTargetWidth = UserControl.ScaleWidth - borderWidthTwips
End Function
And I'm almost completely ready to the RichTextBox have a background image, or a semi-transparent image capturing what's behind the user control, just a few flickering adjustments...
Greetings...
It doesn't work, it doesn't give the full height of the text in the Krool RTB...Quote:
Originally Posted by James Reynolds
At the moment, for text only, this code below perfectly measures the total height using a visible = false picturebox.
But there should be, or maybe there is in subclassed RTB, a way to know the total height - including the non-visible parts - according to the width that the RTB has, but that includes the images or objects that an RTB can have...
It works by calculating letter by letter - spaces and vbcr and vblf and so on - the width, when it exceeds the width of the RTB - which is the same in the Picturebox - it makes a line break in the last space, so as not to put cut words, and so on until the end, and the last currentY gives the total height, but only for text - unicode included -...
Krool, sorry, you don't know how to put a property that gives the total height with rich text?
Code:Private Declare Function GetTextExtentPoint32W Lib "gdi32" (ByVal hdc As Long, ByVal lpString As Long, ByVal c As Long, lpSize As SIZE) As Long
Private Type SIZE
cx As Long
cy As Long
End Type
Private Function GetTotalTextHeightUsingPictureBox(rtbFont As StdFont, rtbWidth As Long, text As String, picBox As PictureBox) As Long
' Set the width of the PictureBox to match the width of the RichTextBox
picBox.ScaleMode = vbPixels
picBox.Width = rtbWidth / Screen.TwipsPerPixelX
' Copy the font from the RichTextBox to the PictureBox
Set picBox.Font = rtbFont
' Prepare the PictureBox to measure the text
picBox.AutoRedraw = True
' Get the device context (DC) of the PictureBox
Dim hdc As Long
hdc = picBox.hdc
' Variables for text size
Dim currentX As Long, currentY As Long
Dim lineHeight As Long
Dim textSize As SIZE
Dim charIndex As Long
Dim currentChar As String
Dim wordBuffer As String
Dim wordWidth As Long
' Initialize coordinates and line height
currentX = 0
currentY = 0
lineHeight = 0
wordBuffer = ""
wordWidth = 0
' Loop through each character in the text
For charIndex = 1 To Len(text)
currentChar = Mid$(text, charIndex, 1)
' If it is a line break, increment currentY and reset currentX
If currentChar = vbCr Or currentChar = vbLf Then
' Add the height of the current line if it exists
If lineHeight = 0 Then
' If we haven't established a line height yet, measure a standard character to use it
GetTextExtentPoint32W hdc, StrPtr("A"), 1, textSize
lineHeight = textSize.cy
End If
currentY = currentY + lineHeight
currentX = 0
lineHeight = 0
wordBuffer = ""
wordWidth = 0
ElseIf currentChar = " " Then
' Measure the current word buffer
If Len(wordBuffer) > 0 Then
GetTextExtentPoint32W hdc, StrPtr(wordBuffer), Len(wordBuffer), textSize
wordWidth = textSize.cx
' Check if the word exceeds the width of the PictureBox
If currentX + wordWidth > picBox.ScaleWidth Then
' Make a line break
currentY = currentY + lineHeight
currentX = 0
lineHeight = 0
End If
' Draw the word
currentX = currentX + wordWidth
' Maintain the maximum height of the current line
If textSize.cy > lineHeight Then
lineHeight = textSize.cy
End If
End If
' Add the space
GetTextExtentPoint32W hdc, StrPtr(currentChar), 1, textSize
currentX = currentX + textSize.cx
' Reset word buffer
wordBuffer = ""
Else
' Add character to word buffer
wordBuffer = wordBuffer & currentChar
End If
Next charIndex
' Measure and add the last word if there is remaining text
If Len(wordBuffer) > 0 Then
GetTextExtentPoint32W hdc, StrPtr(wordBuffer), Len(wordBuffer), textSize
wordWidth = textSize.cx
If currentX + wordWidth > picBox.ScaleWidth Then
' Make a line break
currentY = currentY + lineHeight
currentX = 0
lineHeight = 0
End If
currentX = currentX + wordWidth
If textSize.cy > lineHeight Then
lineHeight = textSize.cy
End If
End If
' Add the last line if there is remaining text
If currentX > 0 Or lineHeight > 0 Then
currentY = currentY + lineHeight
End If
' Return the total height of the text in pixels
GetTotalTextHeightUsingPictureBox = currentY
End Function
You are returning the result of the SendMessage/EM_FORMATRANGE call in GetRichTextHeight, which I believe is the number of characters printed. Instead your should return fr.rc.bottom to get the height of the text in twips (or 0 if fr.rc.bottom = &H7FFFFFFF).Quote:
Originally Posted by James Reynolds
Sorry for late response.Quote:
Originally Posted by SMC1979
The Group.ListItemIndices is kind of slow as it needs to iterate through all items to know which indexes are attached to a group.
If you only need the overall Count (not indexes) you might try below code if it is faster:
Unfortunately this is not in-built into the Group class object as a quick alternative. If you tried and confirm I might add it. :)Code:Dim LVG_V61 As LVGROUP_V61
With LVG_V61
.LVG.cbSize = LenB(LVG_V61)
.LVG.Mask = LVGF_ITEMS
End With
SendMessage ListViewHandle, LVM_GETGROUPINFO, ID, ByVal VarPtr(LVG_V61)
Debug.Print LVG_V61.cItems
I suggest as:
in the Group class object.Code:Public Property Get ListItemCount As Long
For the ListItemIndices property we can speed up the significantly as of Vista+. For XP it would need to fallback to the slow version.
The improved code would be:
The msdn documentation is here misleading and I first thought LVNI_SAMEGROUPONLY is broken. It must be combined with LVNI_VISIBLEORDER even though they state those flags are mutually exclusive.Code:Dim LVG_V61 As LVGROUP_V61
With LVG_V61
.LVG.cbSize = LenB(LVG_V61)
.LVG.Mask = LVGF_ITEMS
SendMessage ListViewHandle, LVM_GETGROUPINFO, ID, ByVal VarPtr(LVG_V61)
While .iFirstItem > -1
FGroupListItemIndices.Add (.iFirstItem + 1)
.iFirstItem = CLng(SendMessage(ListViewHandle, LVM_GETNEXTITEM, .iFirstItem, ByVal LVNI_ALL Or LVNI_VISIBLEORDER Or LVNI_SAMEGROUPONLY))
Wend
End With
Note that the following flags, for use only with Windows Vista, are mutually exclusive of any other flags in use: LVNI_VISIBLEONLY, LVNI_SAMEGROUPONLY, LVNI_VISIBLEORDER, LVNI_DIRECTIONMASK, and LVNI_STATEMASK.
Update released.
Major performance improvement of the .ListItemIndices property in the LvwGroup class. (comctl version 6.1 [Vista+]; 6.0 remains slow [XP])
Included the .ListItemCount property in the LvwGroup class. (comctl version 6.1 [Vista+] only)
Ok and Thanks jpbro, but I tested with ChatGPT and there has been no way to make it work, there is this that does work but without taking into account images or objects:Quote:
Originally Posted by jpbro
And I cannot understand why in years an RTBTotalHeight property or something similar has not been added, because in many cases if you want to show all the content of the RTB, it is important to know the height of everything in the RTB... For example for put in a ToolTip with RichTextBox - a very good tooltip -, is necessary know the total height of the content of the RTB...Code:Private Function GetTotalTextHeight(rtbHwnd As Long, rtbFont As StdFont, Text As String) As Long
Dim iPT1 As POINTAPI
Dim iPt2 As POINTAPI
Dim iCharPos As Long
Dim lTotalHeight As Long
' Get the position of the first character (start of the text)
SendMessageAnyAny rtbHwnd, EM_POSFROMCHAR, iPT1, ByVal CLng(0)
' Get the index of the first character of the last line
Dim lastLineIndex As Long
lastLineIndex = SendMessage(rtbHwnd, EM_LINEFROMCHAR, Len(Text) - 1, 0&)
' Get the position of the first character of the last line
iCharPos = SendMessage(rtbHwnd, EM_LINEINDEX, ByVal lastLineIndex, 0&)
' Get the position of the last line
If iCharPos > -1 Then
SendMessageAnyAny rtbHwnd, EM_POSFROMCHAR, iPt2, ByVal iCharPos
' Calculate the total height of the text
lTotalHeight = iPt2.Y - iPT1.Y
' Ensure to add the font height if necessary
If Not IsNull(rtbFont.Size) Then
lTotalHeight = lTotalHeight + ScaleY(rtbFont.Size, vbPoints, vbPixels)
End If
End If
' Return the total height in pixels
GetTotalTextHeight = lTotalHeight
End Function
I haven't checked by looking at the subclassed vertical scroll bar, I have to try to look there...
At the moment I'm finishing treating the text as simple html, that is, with bold, italic, underline, and font color and font size, I've added 2 properties:
HtmlDefColor (The color you want to set by default to the Text)
HtmlText (true or false)
And I am finishing the code for manage this codes... It works for my needs, because Krool's RTB doesn't seem to support the \b \b0 style codes (At least I've tried and it doesn't recognize them)...
And I understand that Krool doesn't tell me anything, what a job he's done, ufff!!! And what a good job he's done with all these ocx with Unicode, excellent work to give it away for free too...
There is a way to make it work. Take your original ChatGPT code, put Option Explicit at the top and try running it. It won't work because there are missing bits (SendMessage and other API declarations, RECT definition, EM_FORMATRANGE constant, etc...). Add all the missing bits as necessary, until it runs. Once it will run, change the GetRichTextHeight = result line to:Quote:
Originally Posted by James Reynolds
And GetRichTextHeight will now return the height of the RTF content (including images and whatever else might be there).Code:GetRichTextHeight = IIf(fr.rc.Bottom = &H7FFFFFFF, 0, fr.rc.Bottom)
So simple!!!Quote:
Originally Posted by jpbro
And that's it, ChatGPT may have excellent AI for those who use it, but the one they give to normal people is very bad!!!
It is very useful for consulting things, and very simple codes, but as soon as something gets complicated, just a little, little by little, ChatGPT gets complicated, and more than helping, it wastes time, as soon as I see that it is going to mess things up, I say goodbye, and I go look for myself here...
And what danger does it have for the future...
Thanks jpbro, you have helped me a lot, and couldn't ChatGPT know that simple code? Incredible...
[QUOTE=jpbro;5661220]There is a way to make it work. Take your original ChatGPT code, put Option Explicit at the top and try running it. It won't work because there are missing bits (SendMessage and other API declarations, RECT definition, EM_FORMATRANGE constant, etc...). Add all the missing bits as necessary, until it runs. Once it will run, change the GetRichTextHeight = result line to:
But not work well...Code:Private Function GetRichTextHeight(rtbHwnd As Long, rtbFont As StdFont, Text As String, rtbWidth As Long) As Long
Dim fr As FORMATRANGE
Dim rcDrawTo As RECT
Dim rcPage As RECT
Dim iPT1 As POINTAPI
Dim lTotalHeight As Long
Dim hdc As Long
' Get a device context for the entire screen
hdc = GetDC(0)
' Initialize the FORMATRANGE structure
With fr
' Use the same device context for measuring and rendering
.hdc = hdc
.hdcTarget = hdc
' Set up the print area dimensions (rcPage) and the drawing area dimensions (rcDrawTo)
rcPage.Left = 0
rcPage.Top = 0
rcPage.Right = rtbWidth
rcPage.Bottom = 20000
rcDrawTo.Left = 0
rcDrawTo.Top = 0
rcDrawTo.Right = rtbWidth
rcDrawTo.Bottom = &H7FFFFFFF
.rc = rcDrawTo
.rcPage = rcPage
' Set the range of characters to format
.chrg.cpMin = 0
.chrg.cpMax = Len(Text)
' Send EM_FORMATRANGE message to measure the content
SendMessage rtbHwnd, EM_FORMATRANGE, True, ByVal VarPtr(fr)
' Release the device context
ReleaseDC 0, hdc
End With
' Return the height of the RTF content
GetRichTextHeight = IIf(fr.rc.Bottom = &H7FFFFFFF, 0, fr.rc.Bottom)
End Function
Well, this appear to be work well:Quote:
Originally Posted by jpbro
Code:Private Function GetRichTextHeight(rtbHwnd As Long, rtbFont As StdFont, Text As String, rtbWidth As Long) As Long
' Declare required variables
Dim fr As FORMATRANGE
Dim rcDrawTo As RECT, rcPage As RECT
Dim hdcPrinter As Long
Dim result As Long
' Get the device context for the display
hdcPrinter = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
' Set up the FORMATRANGE structure
fr.hdc = hdcPrinter
fr.hdcTarget = hdcPrinter
' Define the printable area (relative to page size)
With rcPage
.Left = 0
.Top = 0
.Right = rtbWidth ' Use the provided width of the RichTextBox/UserControl
.Bottom = &H7FFFFFFF ' Set the bottom to maximum to measure the height
End With
' Define the drawing area on the page (same as the printable area)
rcDrawTo = rcPage
' Set up FORMATRANGE with page and drawing area
fr.rcPage = rcPage
fr.rc = rcDrawTo
fr.chrg.cpMin = 0 ' Start of the text
fr.chrg.cpMax = -1 ' End of the text
' Send EM_FORMATRANGE message to measure the text without rendering
result = SendMessage(rtbHwnd, EM_FORMATRANGE, False, fr)
' Return the height of the formatted text
GetRichTextHeight = IIf(fr.rc.Bottom = &H7FFFFFFF, 0, fr.rc.Bottom)
' Release resources
DeleteDC hdcPrinter
SendMessage rtbHwnd, EM_FORMATRANGE, False, ByVal CLng(0)
End Function
And I don't know if there is any way to know how many visible lines there are in Krool's RTB - it is possible perhaps that by mixing some methods this data can be obtained, but I prefer to have it in a direct property, more than anything to easily go to the end of the text or to the beginning -, I have done this and it works for me, and in case it is useful to someone, I think it is also an important piece of data to know, how many lines are visible:
Now if I want to go to the last line starting with text that is visible, I do this:Code:Public Property Get GetLinesVisibles() As Long
GetLinesVisibles = GetLinesVisiblesFunc(richTextBoxHandle)
End Property
Private Function GetLinesVisiblesFunc(rtbHwnd As Long) As Long
Dim firstVisibleLine As Long
Dim totalLines As Long
Dim clientHeight As Long
Dim lineIndex As Long
Dim charIndex As Long
Dim linePos As POINTAPI
Dim nextLinePos As POINTAPI
Dim visibleLines As Long
Dim cumulativeHeight As Long
Dim prevLinePosY As Long
Dim rc As RECT
' Get the index of the first visible line
firstVisibleLine = SendMessage(rtbHwnd, EM_GETFIRSTVISIBLELINE, 0, ByVal 0&)
' Get the total number of lines
totalLines = SendMessage(rtbHwnd, EM_GETLINECOUNT, 0, ByVal 0&)
' Get the height of the RichTextBox client area
GetClientRect rtbHwnd, rc
clientHeight = rc.Bottom - rc.Top
' Initialize variables
lineIndex = firstVisibleLine
cumulativeHeight = 0
visibleLines = 0
' Iterate over the lines starting from the first visible one
Do While lineIndex < totalLines
' Get the character index of the current line
charIndex = SendMessage(rtbHwnd, EM_LINEINDEX, lineIndex, ByVal 0&)
' Get the character's position in client coordinates
If SendMessage(rtbHwnd, EM_POSFROMCHAR, VarPtr(linePos), ByVal charIndex) = -1 Then
Exit Do
End If
' Get the position of the next line
If lineIndex + 1 < totalLines Then
Dim nextCharIndex As Long
nextCharIndex = SendMessage(rtbHwnd, EM_LINEINDEX, lineIndex + 1, ByVal 0&)
If SendMessage(rtbHwnd, EM_POSFROMCHAR, VarPtr(nextLinePos), ByVal nextCharIndex) = -1 Then
Exit Do
End If
Else
' If it's the last line, estimate the line height
nextLinePos.Y = linePos.Y + (linePos.Y - prevLinePosY)
End If
' Calculate the height of the line
Dim lineHeight As Long
lineHeight = nextLinePos.Y - linePos.Y
' Handle possible zero or negative line heights
If lineHeight <= 0 Then
' Use an average line height if necessary
lineHeight = clientHeight / (visibleLines + 1)
End If
' Add the line height to the cumulative total
cumulativeHeight = cumulativeHeight + lineHeight
' Check if the cumulative total exceeds the client area height
If cumulativeHeight > clientHeight Then
Exit Do
End If
' Increment the visible lines counter
visibleLines = visibleLines + 1
' Save the previous Y position
prevLinePosY = linePos.Y
' Prepare for the next iteration
lineIndex = lineIndex + 1
Loop
' Display the number of visible lines
GetLinesVisiblesFunc = visibleLines
End Function
Although I still need to check if the first visible line is a VbCrLf or VbCr or VbLf, because it would be better if that line was skipped...Code:RichTextBox1.ScrollToLine RichTextBox1.GetLineCount - RichTextBox1.GetLinesVisibles + 1
Maybe it can be done with what the Krool RTB already has, but I would like to know the content of each line, it must be easy...
One GetTextLine method passing the parameter of the line you want to know, it would be interesting...
Greetings...
Well, here is the Krool RichTextBox user control with my additions, it accepts basic html text (<font name, font color, font size, bold, italic, underline)
It is semi-transparent capturing from the container's hdc, I can know the total height of the content of the Krool RichTextBox Unicode Utf8, I can know the text of each line, and maybe I'm forgetting something else, but for my needs it is almost complete, when I consider it checked and complete, I will upload it to the CodeBank:
https://www.youtube.com/watch?v=jwDbmVb2N_c
Greetings...
Does anyone have some code handy to sort the VBCCR Listview rows when a column header is clicked on? The sort needs to be able to handle/differentiate between numeric/date/string data types.
I've tried to create this myself but am running into numerous hurdles. Figured it's so common that someone else has surely already created this.
TIA!
See below how I dealt with it. Columheader text gets a + or - sign to show ascending or descending sorting. Sort column and sort order are stored in the registry and retrieved and applied when the form with the listview is opened.Quote:
Originally Posted by AAraya
Code:Private Sub lvMerchandiseSectionDetails_ColumnClick(ByVal ColumnHeader As VBCCR17.LvwColumnHeader)
Dim iLastColumnSortedOn As Integer
If ColumnHeader.Index > 0 Then
iLastColumnSortedOn = CInt(GetSetting(Appname:=APPLICATION_NAME, Section:="Merchandise Section Lists", Key:=Me.Name & "." & lvMerchandiseSectionDetails.Name & ".LastColumnSortedOn", Default:=-1))
If iLastColumnSortedOn <> -1 Then
If iLastColumnSortedOn <> (ColumnHeader.Index) Then
'Remove sorting sign from current sort column, as the user clicked another column
If lvMerchandiseSectionDetails.ColumnHeaders.Count >= iLastColumnSortedOn Then
lvMerchandiseSectionDetails.ColumnHeaders(iLastColumnSortedOn).Text = Left$(lvMerchandiseSectionDetails.ColumnHeaders(iLastColumnSortedOn).Text, Len(lvMerchandiseSectionDetails.ColumnHeaders(iLastColumnSortedOn).Text) - 2)
End If
'Sort the new column ascending
With lvMerchandiseSectionDetails
.ColumnHeaders(ColumnHeader.Index).Text = .ColumnHeaders(ColumnHeader.Index).Text & " +"
.SortKey = ColumnHeader.Index - 1
.SortOrder = lvwAscending
.Sorted = True
If ColumnHeader.Tag = "Numeric" Then
.SortType = LvwSortTypeNumeric
ElseIf ColumnHeader.Tag = "Date" Then
.SortType = LvwSortTypeDate
Else
.SortType = LvwSortTypeText
End If
End With
'Save the settings in the registry
SaveSetting Appname:=APPLICATION_NAME, Section:="Merchandise Section Lists", Key:=Me.Name & "." & lvMerchandiseSectionDetails.Name & ".LastColumnSortedOn", Setting:=(ColumnHeader.Index)
SaveSetting Appname:=APPLICATION_NAME, Section:="Merchandise Section Lists", Key:=Me.Name & "." & lvMerchandiseSectionDetails.Name & ".LastSortType", Setting:=lvwAscending
Else
'User clicked same column, change the sorting order
'Remove sorting sign from current sort column
lvMerchandiseSectionDetails.ColumnHeaders(iLastColumnSortedOn).Text = Left$(lvMerchandiseSectionDetails.ColumnHeaders(iLastColumnSortedOn).Text, Len(lvMerchandiseSectionDetails.ColumnHeaders(iLastColumnSortedOn).Text) - 2)
If CInt(GetSetting(Appname:=APPLICATION_NAME, Section:="Merchandise Section Lists", Key:=Me.Name & "." & lvMerchandiseSectionDetails.Name & ".LastSortType", Default:=-1)) = lvwAscending Then
'Sort the column descending
With lvMerchandiseSectionDetails
.ColumnHeaders(iLastColumnSortedOn).Text = .ColumnHeaders(iLastColumnSortedOn).Text & " -"
.SortKey = ColumnHeader.Index - 1
.SortOrder = lvwDescending
.Sorted = True
If ColumnHeader.Tag = "Numeric" Then
.SortType = LvwSortTypeNumeric
ElseIf ColumnHeader.Tag = "Date" Then
.SortType = LvwSortTypeDate
Else
.SortType = LvwSortTypeText
End If
End With
'Save the settings in the registry
SaveSetting Appname:=APPLICATION_NAME, Section:="Merchandise Section Lists", Key:=Me.Name & "." & lvMerchandiseSectionDetails.Name & ".LastColumnSortedOn", Setting:=(ColumnHeader.Index)
SaveSetting Appname:=APPLICATION_NAME, Section:="Merchandise Section Lists", Key:=Me.Name & "." & lvMerchandiseSectionDetails.Name & ".LastSortType", Setting:=lvwDescending
Else
'Remove the sorting, i.e. apply default sort based on the ID column
With lvMerchandiseSectionDetails
.SortKey = 1
.SortOrder = lvwAscending
.Sorted = True
If ColumnHeader.Tag = "Numeric" Then
.SortType = LvwSortTypeNumeric
ElseIf ColumnHeader.Tag = "Date" Then
.SortType = LvwSortTypeDate
Else
.SortType = LvwSortTypeText
End If
End With
'Save the settings in the registry
SaveSetting Appname:=APPLICATION_NAME, Section:="Merchandise Section Lists", Key:=Me.Name & "." & lvMerchandiseSectionDetails.Name & ".LastColumnSortedOn", Setting:=-1
SaveSetting Appname:=APPLICATION_NAME, Section:="Merchandise Section Lists", Key:=Me.Name & "." & lvMerchandiseSectionDetails.Name & ".LastSortType", Setting:=-1
End If
End If
Else
'First time the user clicked on something.
'Sort the new column ascending
With lvMerchandiseSectionDetails
.ColumnHeaders(ColumnHeader.Index).Text = .ColumnHeaders(ColumnHeader.Index).Text & " +"
.SortKey = ColumnHeader.Index - 1
.SortOrder = lvwAscending
.Sorted = True
If ColumnHeader.Tag = "Numeric" Then
.SortType = LvwSortTypeNumeric
ElseIf ColumnHeader.Tag = "Date" Then
.SortType = LvwSortTypeDate
Else
.SortType = LvwSortTypeText
End If
End With
'Save the setting in the registry
SaveSetting Appname:=APPLICATION_NAME, Section:="Merchandise Section Lists", Key:=Me.Name & "." & lvMerchandiseSectionDetails.Name & ".LastColumnSortedOn", Setting:=(ColumnHeader.Index)
SaveSetting Appname:=APPLICATION_NAME, Section:="Merchandise Section Lists", Key:=Me.Name & "." & lvMerchandiseSectionDetails.Name & ".LastSortType", Setting:=lvwAscending
End If
End If
End Sub
The SortType property along with associated lvwSortTypeConstant values was the key I was missing. All's working properly now. Thanks!
Update released.
Included enum value 'SbrPanelAlignmentLeftRight' for the Alignment property of a Panel in the StatusBar control.
The picture will be left-aligned and the text right-aligned. (instead of aligning both together)
If PictureOnRight property is true the logic is reversed. If no picture exists it behaves the same as 'SbrPanelAlignmentLeft'.
The 1.8 OCX has been updated with the new enum value. (type lib edit)
Win10, VB6sp6, VBCCR 1.8.55
I have set up a max value of 9999 for the SpinBox but i still can enter higher numbers via the number keys.
After pressing TAB the control doenst check the curent value in the spinbox against the max value setting.
Is this behavior a bug or by design?
The Text can be altered to higher than 9999 in your example.Quote:
Originally Posted by Mith
The Value property however is still 9999.
Usually I call .ValidateText method in the SpinBox_Validate event to sync the text by the value.
calling .ValidateText in the SpinBox_Validate event fixed the problem!Quote:
Originally Posted by Krool
Thx a lot!
*** deleted ***
Krool, many thanks for the VBCCR controls.
I'm using VBCCR18.ocx for building a listview on a userform in MS Excel VBA.
Since MS's own listview does not support unicode, I found your listview control very useful and I'm very thankful to you about this.
I am now in the process of rewriting my code to use VBCCR18's listview control.
1. I'd like to report that while the listitems in MS's listview control could be checked (with checkboxes on) like LV1.Listitem(1).Checked=True and there will be a checkmark on that listitem's checkbox without triggering the LV1_ItemCheck(ByVal Item As MSComctlLib.ListItem) event!
However, with the VBCCR18's listview, the ItemCheck event was triggered.
This maybe by design by your intentionally.
I am just reporting what I found.
While I can work around this without much hassle, do you think that this should be this way or should I prepare for a change in this behavior in the future releases?
2.With the VBCCR18's Treeview, I found that the Treeview's checkboxes are a bit lower than the +/- signs and the Node's Text in terms of vertical alignment.
Therefore, is there any option to change the said text vertical alignment?
3.I am also using VBFlexGrid18.ocx and I implemented a columnheader click to change sort direction and sort behavior.
In this manner, I found that
.Col = Col
.ColSort(Col) = FlexSortGenericAscending
.Sort = FlexSortUseColSort
inside FG_CellClick(ByVal Row As Long, ByVal Col As Long, ByVal Button As Integer) sub.
I have to include .Col=Col for Col0 which is a fixedColumn. The other non-fixedcolumns do not need that part.
Is that intentional?
Many thanks in advance.
I can make videos or screenshots if you need a clearer picture.
Thanks for your feedback.Quote:
Originally Posted by tragicshadow
1.
Interesting that the ItemCheck event is not fired when checking a listitem by code in the MS listview.
However, in the VBCCR ListView I just handle LVN_ITEMCHANGED and test for LVIS_CHECKED.
So it could be a change in comctl32.dll. Because mscomctl.oxc is a zombie version of comctl32.dll. (very old)
Bottom line, I won't artificially interrupt in the event handling. So adjust your code accordingly..
2.
no idea. Seems to be new windows default design.
3.
A fixed column is a non-movable area for your focus caret. So putting .Col = Col (change focus caret by code) is a necessary.
Many thanks for your kind reply.Quote:
Originally Posted by Krool
For 1.I will adjust my code but for clarity's sake, allow me to attach 2 .GIFs.
a). for MSCOMCTL listview
Attachment 193927
b). for VBCCR18 listview
Attachment 193928
For 2.I will try to live with it but let me upload a screenshot. As for further info on this, I am using a screen scaling factor of 125% from Windows Settings because the resolution is set at 1920x1200 on a 3200x2000 (recommended) screen. I am not sure whether this affects or not, just wanted to give you as much info as I could.
Attachment 193929
For 3.Thanks to your kind explanation, I understand the concept now. Thank you.
Have a nice weekend!
I didn't know that .GIF's don't get animated. So, I am posting this to youtube and sharing the links here.Quote:
Originally Posted by tragicshadow
1.MSCOMCTL ocx listview
https://youtu.be/nwPJSuM628w
2.VBCCR18 ocx listview
https://youtu.be/o-yNDWdevQE
Additional finding, I just found out (after making and uploading the videos to youtube) while fixing the code, that even with Application.EnableEvents=False, the ItemCheck event still got fired with VBCCR18's listview, when setting checked=true via Excel VBA code!
I apologize for multiple posts but I honestly thought that .GIFs would be animated.