Wortwolke

Option Explicit ' DLL zum Ausführen von Programmen deklarieren Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _ (ByVal hwnd As Long, ByVal lpOperation As String, _ ByVal lpFile As String, ByVal lpParameters As String, _ ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Sub ErzeugeWortwolke() 'Ein/Ausschalten der Tranzparenz der Verdränger für Layoutansicht, mögliche Werte 0/1 Const iTranzparenz = 1 Dim MyFile, MyFileNum Dim iCounter, iMaxHaeufigkeit, iMinHaeufigkeit, iHaeufigkeit, iHervorhebung, iSkalierung As Integer Dim strFontSize1, strFontSize2, strFontSize3, strFontSize4, strFontSize5 As String Dim strTranzparenz, strWort As String ' Erzeuge Wortliste als HTML-Datei MyFile = ThisWorkbook.Path & "\Wortwolke.html" ' Minimum und Maximum der Häufigkeit des Auftretens der Wortbausteine ermitteln iMaxHaeufigkeit = MaxHaeufigkeit() iMinHaeufigkeit = MinHaeufigkeit() ' Manuelle Skalierung berechnen If ((Cells(1, 5).Value = "") Or (Not IsNumeric(Cells(1, 5).Value))) Then MsgBox "Keine Skalierung in Zelle E1 angegeben", vbOKOnly, "Fehler" Else ' FontSize Dimensionierung aus Skalierung abschätzen strFontSize1 = Str(Round(1.5 * Cells(1, 5).Value / 100, 1)) strFontSize2 = Str(Round(1.8 * Cells(1, 5).Value / 100, 1)) strFontSize3 = Str(Round(2.4 * Cells(1, 5).Value / 100, 1)) strFontSize4 = Str(Round(2.9 * Cells(1, 5).Value / 100, 1)) strFontSize5 = Str(Round(3.5 * Cells(1, 5).Value / 100, 1)) ' HTML File anlegen MyFileNum = FreeFile() Open MyFile For Output As #MyFileNum ' HTML Kopf schreiben Print #MyFileNum, "" Print #MyFileNum, "" Print #MyFileNum, " " Print #MyFileNum, " Wortwolke" ' Stylesheets definieren -> 5 Elemente zur Zeit, 1280 pixel breit Print #MyFileNum, " " Print #MyFileNum, " " ' HTML aufbauen Print #MyFileNum, " " Print #MyFileNum, "

" ' Verdränger aufbauen If iTranzparenz = 0 Then strTranzparenz = "background-color:#CCCCCC; border:solid; border-width:1px; " Else strTranzparenz = "background-color:transparent; " End If ' Hintergrund Grafix als SVG einbinden Print #MyFileNum, " " Print #MyFileNum, "

" Print #MyFileNum, " " ' Verdränger Horizontale Ebene 1 Print #MyFileNum, " " ' Verdränger Horizontale Ebene 2 Print #MyFileNum, " " Print #MyFileNum, " " ' Verdränger Horizontale Ebene 3 Print #MyFileNum, " " Print #MyFileNum, " " ' Verdränger Horizontale Ebene 4 Print #MyFileNum, " " Print #MyFileNum, " " ' Verdränger Horizontale Ebene 5 Print #MyFileNum, " " Print #MyFileNum, " " ' Verdränger Horizontale Ebene 6 Print #MyFileNum, " " Print #MyFileNum, " " ' Verdränger Horizontale Ebene 7 Print #MyFileNum, " " ' Wortbausteine in Wortwolke schreiben iCounter = 1 While (Cells(iCounter, 1).Value <> "") ' Häufigkeit aus Zellen lesen strWort = Cells(iCounter, 1).Value iHaeufigkeit = Cells(iCounter, 2).Value ' Hervorhebung und Gruppierung der Häufigkeit bestimmen iHervorhebung = Int((iHaeufigkeit - iMinHaeufigkeit) / (iMaxHaeufigkeit - iMinHaeufigkeit) * 4) + 1 ' .. und als SPAN-Element ausgeben Print #MyFileNum, " " & strWort & "" iCounter = iCounter + 1 Wend ' HTML schließen Print #MyFileNum, "

" Print #MyFileNum, " " Print #MyFileNum, "" ' HTML File schließen Close #MyFileNum ' Erzeugtes HTML File im Browser öffnen ShellExecute Application.hwnd, "Open", MyFile, vbNullString, vbNullString, vbNormalFocus End If End Sub Function MinHaeufigkeit() Dim iCounter, iMinInt iMinInt = 0 iCounter = 1 iMinInt = Cells(iCounter, 2).Value iCounter = 1 While (Cells(iCounter, 1).Value <> "") If iMinInt > Cells(iCounter, 2).Value Then iMinInt = Cells(iCounter, 2).Value End If iCounter = iCounter + 1 Wend MinHaeufigkeit = iMinInt End Function Function MaxHaeufigkeit() Dim iCounter, iMaxInt iMaxInt = 0 iCounter = 1 While (Cells(iCounter, 1).Value <> "") If iMaxInt < Cells(iCounter, 2).Value Then iMaxInt = Cells(iCounter, 2).Value End If iCounter = iCounter + 1 Wend MaxHaeufigkeit = iMaxInt End Function