Date: 02-16-2022
Return to Index
created by gbSnippets
'This utility creates a graphical image of all words in a text string,
'randomly placed but sized according to frequency. It's similar to Word
'Clouds you see on the Internet.
'Compiler Comments:
'This code uses a resizable Graphic Control, so it will compile only in
'PBWin10. In PBWin9, the graphic control cannot be resized, so you have
'to KILL the control, then use Control Add Graphic to recreate the control
'at the new size.
'Primary Code:
'This utility works by parsing a text string for words, while counting
'each word's frequency. Words are then displayed randomly within a graphic
'control, but with font size proportaional to the word's frequency.
'The DrawCloud function (below) is the primary code of interest). My
'freeward application gbWordCloud provides a much greater feature set.
'Compilable Example: (Jose Includes)
#Compiler PBWin 10
#Compile EXE
#Dim All
%Unicode=1
#Debug Display On
#Debug Error On
#Include "Win32API.inc"
Type Cloud
text As String * 20
freq As Long ' 0 to 100 %
rgb As Long 'color 'reserved
trans As Long '0-100 % 'reserved
rc As Rect
fontSize As Long
mark As Long
End Type
%IDC_ButtonCreate = 500
%IDC_ButtonShow = 501
%IDC_TextIn = 502
%IDC_Graphic = 503
%IDC_Statusbar = 504
Global hDlg,hGraphic As Dword, MaxFontSize, MinFontSize, MaxFreq, OldPos, OnWord, OffWord,BGColor As Long
Global CWords() As Cloud, Words() As String, FontName As String, FontsA(), FontsB() As Dword
Function PBMain() As Long
Local style&
style& = %WS_TabStop Or %WS_Border Or %ES_Left Or %ES_AutoHScroll Or %ES_AutoVScroll _
Or %ES_MultiLine Or %ES_NoHideSel Or %ES_WantReturn
Dialog New Pixels, 0, "Word Cloud",300,300,520,730, %WS_OverlappedWindow To hDlg
Control Add Button, hDlg, %IDC_ButtonCreate,"Create", 10,10,80,20
Control Add Button, hDlg, %IDC_ButtonShow,"Show List", 110,10,90,20
Control Add TextBox, hDlg, %IDC_TextIn,"Paste the words." + $CrLf + "Press the create button." + $CrLf + "See the words cloud.", 10,40,500,150, Style&
Control Add Graphic, hDlg, %IDC_Graphic, "", 10,200,500,500, %WS_Border
Control Add Statusbar, hDlg, %IDC_StatusBar, "", 0,0,0,0
Control Handle hDlg, %IDC_Graphic To hGraphic
Graphic Attach hDlg, %IDC_Graphic, ReDraw
Graphic Color -1, -2
Graphic Clear BGColor, 0
Dialog Show Modal hDlg Call DlgProc
End Function
CallBack Function DlgProc() As Long
Local i,w,h As Long, pt,ptg,ptd As Point
Select Case Cb.Msg
Case %WM_InitDialog
MinFontSize = 8
MaxFontSize = 48
FontName = "Arial"
BGColor = %rgb_LightGray
CreateFonts
Randomize Timer
oldPos = -1
Case %WM_MouseMove
GetCursorPos pt 'pt has xy screen coordinates
ptd = pt : ptg = pt
ScreenToClient hDlg, ptd 'pt now has dialog client coordinates
ScreenToClient hGraphic, ptg 'pt now has dialog client coordinates
If ChildWindowFromPoint(hDlg,ptd)=hGraphic Then
For i = 0 To UBound(CWords)
OnWord = 0
If PtInRect(CWords(i).rc,ptg) Then
OnWord = 1
Statusbar Set Text hDlg, %IDC_Statusbar, 1, 0, Trim$(CWords(i).Text) + Str$(CWords(i).freq)
CWords(i).Mark = 1
If oldPos <> -1 Then ClearOld : CWords(oldPos).Mark = 0
DrawNew(i)
oldPos = i
Exit For
End If
Next i
Else
OnWord = 0
End If
If OnWord = 0 Then Statusbar Set Text hDlg, %IDC_Statusbar, 1, 0, ""
Case %WM_Command
Select Case Cb.Ctl
Case %IDC_ButtonCreate : DrawCloud
Case %IDC_ButtonShow : DisplayResult
End Select
Case %WM_Size
Dialog Get Client hDlg To w,h
Graphic Set Size w-20,h-230
Control Set Size hDlg, %IDC_TextIn, w-20,150
ReDrawCloud
End Select
End Function
Sub DisplayResult
Local i As Long,result$
Dim tempArray(UBound(Words())) As String
For i = 0 To UBound(CWords)
result$ = result$ + Format$(CWords(i).freq,"0000 ") + Trim$(CWords(i).Text) + " " + Str$(CWords(i).FontSize)+ _
Space$(5) + Str$(CWords(i).rc.nLeft) + Str$(CWords(i).rc.nRight) + Str$(CWords(i).rc.nTop) + Str$(CWords(i).rc.nBottom) + $CrLf
Next i
result$ = Trim$(result$,$CrLf)
ReDim tempArray(ParseCount(result$, $CrLf)-1)
Parse result$, tempArray(), $CrLf
Array Sort tempArray()
Open Exe.Path$ + "results.txt" For Output As #1
Print #1, Join$(tempArray(),$CrLf) + $CrLf + "MaxFreq: " + Str$(MaxFreq)
Close #1
i = Shell ("notepad.exe " + Exe.Path$ + "results.txt", 1) 'does not wait for it to close
End Sub
Sub DrawCloud
Local delimiter$,result$,temp$,i,j,w,h,iPos,gW,gH As Long
MousePtr 11
'get sorted list of all words
Control Get Text hDlg, %IDC_TextIn To temp$
delimiter$ = Chr$(0 To 64, 91 To 96, 123 To 127) '<--- all non-letter
temp$ = LCase$(Trim$(temp$, Any delimiter))
ReDim Words(ParseCount(temp$, Any delimiter)-1), CWords(UBound(Words))
Parse temp$, Words(), Any delimiter
Array Sort Words()
'create CWords() - word list and frequency
CWords(iPos).Text = Words(0) : CWords(iPos).freq = 1 : MaxFreq = 1
For i = 1 To UBound(Words)
If Len(Trim$(Words(i))) = 0 Then Iterate For
If Words(i) = Words(i-1) Then
Incr CWords(iPos).freq
MaxFreq = Max(MaxFreq,CWords(iPos).freq)
Else
Incr iPos
CWords(iPos).Text = Words(i) : CWords(iPos).freq = 1
End If
Next i
ReDim Preserve CWords(iPos)
'set font sizes, position
' Graphic Color -1, -2
Graphic Clear BGColor, 0
Control Get Client hDlg, %IDC_Graphic To gW,gH
For i = 0 To UBound(CWords)
CWords(i).fontSize = (MaxFontSize-MinFontSize) * (CWords(i).Freq/MaxFreq) + MinFontSize
Graphic Set Font FontsA(CWords(i).FontSize)
Graphic Text Size Trim$(CWords(i).Text) To w,h
CWords(i).rc.nLeft = Rnd(10,gW)
CWords(i).rc.nTop = Rnd(10,gH)
CWords(i).rc.nLeft = Min(CWords(i).rc.nLeft, gW-w-10)
CWords(i).rc.nTop = Min(CWords(i).rc.nTop, gH-h-10)
CWords(i).rc.nRight = CWords(i).rc.nLeft + w
CWords(i).rc.nBottom = CWords(i).rc.nTop + h
Graphic Set Pos (CWords(i).rc.nLeft,CWords(i).rc.nTop)
Graphic Color GetColor(CWords(i).freq/MaxFreq), -2
Graphic Print Trim$(CWords(i).Text)
Next i
Graphic ReDraw
MousePtr 0
End Sub
Sub ClearOld
If oldPos = -1 Then Exit Sub
Graphic Color -1, -2
Graphic Box (CWords(oldPos).rc.nLeft,CWords(oldPos).rc.nTop)-(CWords(oldPos).rc.nRight,CWords(oldPos).rc.nBottom),,BGColor,BGColor,0
Graphic Set Font FontsA(CWords(oldPos).FontSize)
Graphic Set Pos (CWords(oldPos).rc.nLeft,CWords(oldPos).rc.nTop)
Graphic Color GetColor(CWords(oldPos).freq/MaxFreq), -2
Graphic Print Trim$(CWords(oldPos).Text)
Graphic ReDraw
End Sub
Sub DrawNew(iPos As Long)
Graphic Color -1, -2
Graphic Box (CWords(iPos).rc.nLeft,CWords(iPos).rc.nTop)-(CWords(iPos).rc.nRight,CWords(iPos).rc.nBottom),,BGColor,BGColor,0
Graphic Set Font FontsB(CWords(iPos).FontSize)
Graphic Set Pos (CWords(iPos).rc.nLeft,CWords(iPos).rc.nTop)
Graphic Color GetColor(CWords(iPos).freq/MaxFreq), -2
Graphic Print Trim$(CWords(iPos).Text)
Graphic ReDraw
End Sub
Sub CreateFonts
Local i As Long
ReDim FontsA(MinFontSize To MaxFontSize)
ReDim FontsB(MinFontSize To MaxFontSize)
For i = MinFontSize To MaxFontSize
Font New FontName, i, 1 To FontsA(i)
Font New FontName, i, 5 To FontsB(i)
Next i
End Sub
Sub ReDrawCloud
Local delimiter$,result$,temp$,i,j,w,h,iPos,gW,gH As Long
MousePtr 11
'set font sizes, position
Graphic Color -1, -2
Graphic Clear BGColor, 0
For i = 0 To UBound(CWords)
Graphic Set Font FontsA(CWords(i).FontSize)
Graphic Set Pos (CWords(i).rc.nLeft,CWords(i).rc.nTop)
Graphic Color GetColor(CWords(i).freq/MaxFreq), -2
Graphic Print Trim$(CWords(i).Text)
Next i
Graphic ReDraw
MousePtr 0
End Sub
Function GetColor(s As Single) As Long
Local ColorLeft, ColorRight As Long
Local R1,G1,B1,R2,G2,B2 As Long
ColorLeft = BGColor
ColorRight = %rgb_DarkRed
R1 = GetRValue(ColorLeft)
G1 = GetGValue(ColorLeft)
B1 = GetBValue(ColorLeft)
R2 = GetRValue(ColorRight)
G2 = GetGValue(ColorRight)
B2 = GetBValue(ColorRight)
Function = RGB( (R1 + (R2-R1)*s), (G1 + (G2-G1)*s), (B1 + (B2-B1)*s) )
End Function
'gbs_01083
'Date: 03-10-2012
http://www.garybeene.com/sw/gbsnippets.htm