PureBoard

Das deutsche PureBasic-Forum
https://www.purebasic.fr/german/

meine Ascii Tabelle

https://www.purebasic.fr/german/viewtopic.php?t=25795

Seite 1 von 1

meine Ascii Tabelle

Verfasst: 10.08.2012 22:25
von hjbremer
hier einmal meine Asciitabelle, auch wenn es schon die x.te Tabelle ist, ich finde Sie schön.

Code: Alles auswählen

;Ascii Tabelle, PB 4.60 Windows Vista x86 10.08.2012 HJ Bremer

Enumeration
   #window
   #status
   #canvas
   #scroll
   #image1
   #image2
   #container
   #liste
   #combosize
   #combostyle
   #fontmuster
EndEnumeration

Enumeration
   #font0
   #font1
   #font2
   #font3
EndEnumeration

#abstand = 4

EnableExplicit

Procedure.i MakeImage(fontname$, fontsize, fontstyle, rows = 16)
   
   ;cols   = jede Zeile besteht aus 16 Spalten, genannt Box
   ;rows   = Anzahl Zeilen, 14 Zeilen * 16 ergibt Ascii 32 - 255, darf > 14 sein
   ;charnr = Startwert ist Ascii 31, wird in der Schleife um 1 erhöht, dann 32
   
   Protected cols = 16
   Protected charnr = 31
   Protected imgbr, imghh, boxbr, boxhh 
   Protected char$, charbr, charhh, farbe, x, y, posx, posy 
   
   Protected i, j, info$
   Protected minbr = 9999, maxbr = 0, minhh = 9999, maxhh = 0
   
   SetGadgetState(#fontmuster, #PB_Checkbox_Unchecked)

   LoadFont(#font2, fontname$, fontsize, fontstyle)
   StatusBarText(#status, 1, "Size: " + Str(fontsize))
   StatusBarText(#status, 2, fontname$)

   ;-boxbr + hh, minbr + maxbr ermitteln
   
   StartDrawing(CanvasOutput(#canvas))
   
   DrawingFont(FontID(#font1))
   boxhh = TextHeight("X")
   boxbr = TextWidth("000") + #abstand + #abstand
   
   DrawingFont(FontID(#font2))
   boxhh + TextHeight("Xg") 
   boxhh + (#abstand * 3)   
   
   For j = 32 To 255
      charbr = TextWidth(Chr(j)) 
      charhh = TextHeight(Chr(j)) 
      If boxbr < charbr: boxbr = charbr: EndIf
      If charbr
         If charbr > maxbr: maxbr = charbr: EndIf
         If charbr < minbr: minbr = charbr: EndIf
      EndIf
      
   Next   
   boxbr + #abstand + #abstand
   
   info$ = "Höhe: " + Str(charhh) + " | "
   If minbr = maxbr
      info$ + "Fix Breite: " + Str(minbr)
   Else
      info$ + "Breite: " + Str(minbr) + " - " + Str(maxbr)
   EndIf   
   StatusBarText(#status, 0, info$)
   
   StopDrawing()
   
   ;-Image erstellen
   
   imgbr = (boxbr * cols) - 5 
   imghh = (boxhh * rows) 
   CreateImage(#image1, imgbr, imghh)
   
   StartDrawing(ImageOutput(#image1))
   
   Box(0, 0, imgbr, imghh, #Yellow)   
   DrawingMode(#PB_2DDrawing_Transparent)
   
   x = #abstand: y = #abstand   
   
   For i = 1 To rows      
      For j = 1 To cols
         
         ;Rahmen
         Box(x, y, boxbr, boxhh, #Black)      
         Box(x + 1, y + 1, boxbr - 2, boxhh - 2, #White)
         
         charnr + 1      
         
         ;AsciiNr als Überschrift in Box
         DrawingFont(FontID(#font1))
         char$ = RSet(Str(charnr), 3, "0") 
         If charnr > 999: char$ = RSet(Str(charnr), 4, "0"): EndIf   ;für Erweiterung
         charbr = TextWidth(char$) 
         charhh = TextHeight(char$) 
         posx = (boxbr - charbr) / 2
         posy = #abstand      
         DrawText(x + posx, y + posy, char$, #Black) 
         
         ;AsciiZeichen
         DrawingFont(FontID(#font2))
         char$ = Chr(charnr) 
         charbr = TextWidth(char$)  
         posx = (boxbr - charbr) / 2
         posy + charhh + #abstand  
         farbe = #Blue
         If charnr > 255: farbe = $555555: EndIf
         DrawText(x + posx, y + posy, char$, farbe)
         
         ;Spalte nächste Box
         x + boxbr - 1
         
      Next      
      x = #abstand       ;Spalte zurücksetzen
      y + boxhh - 1     ;nächste Zeile 
   Next
   
   StopDrawing()
   
   ;-Resizen
   ResizeGadget(#canvas, 0, 0, ImageWidth(#image1), ImageHeight(#image1))
   SetGadgetAttribute(#canvas, #PB_Canvas_Image, ImageID(#image1))
   
   ResizeGadget(#scroll, 0, 0, ImageWidth(#image1) + 21, WindowHeight(#window) - StatusBarHeight(#status))
   SetGadgetAttribute(#scroll, #PB_ScrollArea_InnerWidth, imgbr)
   SetGadgetAttribute(#scroll, #PB_ScrollArea_InnerHeight, imghh)
   
   ResizeWindow(#window, #PB_Ignore, #PB_Ignore, GadgetWidth(#scroll) + GadgetWidth(#container), #PB_Ignore) 
   ResizeGadget(#container, GadgetWidth(#scroll), #PB_Ignore, #PB_Ignore, #PB_Ignore) 
   
EndProcedure

Procedure.i MakeImage2(fontsize, fontstyle = 0)
   
   StatusBarText(#status, 2, "bitte warten")
      
   Static oldsize, oldstyle
   
   If (oldsize <> fontsize) Or (oldstyle <> fontstyle)
      
      oldsize = fontsize
      oldstyle = fontstyle
      
      ;Font für FontNamen
      Select fontsize
         Case 6 To 9: LoadFont(#font3, "Arial", fontsize - 1)
         Case 10 To 12: LoadFont(#font3, "Arial", fontsize - 2)   
         Case 13 To 14: LoadFont(#font3, "Arial", fontsize - 3)   
         Case 15 To 18: LoadFont(#font3, "Arial", fontsize - 4)     
      EndSelect
      
      Protected fontanz = CountGadgetItems(#liste)   
      Protected imgbr, imghh   
      Protected j, name$, char$, charbr, charhh, minbr, farbe, x, y 
      
      Protected Dim fontpbnr(fontanz), Dim fontname.s(fontanz)
      
      For j = 1 To fontanz      
         fontname(j) = GetGadgetItemText(#liste, j - 1)
         fontpbnr(j) = LoadFont(#PB_Any, fontname(j), fontsize, fontstyle)
      Next
      
      ;-ImageGröße 
      imgbr = GadgetWidth(#canvas) 
      imghh = #abstand 
      char$ = "Test" 
      
      StartDrawing(WindowOutput(#window))     
      For j = 1 To fontanz
         DrawingFont(FontID(fontpbnr(j)))
         charhh = TextHeight(char$)
         DrawingFont(FontID(#font3))
         charbr = TextWidth(fontname(j))
         If minbr < charbr: minbr = charbr: EndIf
         imghh + charhh + #abstand
      Next
      imghh + #abstand
      StopDrawing()
      
      ;-Image beschreiben
      CreateImage(#image2, imgbr, imghh)
      
      x = #abstand
      y = #abstand
      char$ = "Dies ist ein Test" 
      
      StartDrawing(ImageOutput(#image2))
      DrawingMode(#PB_2DDrawing_Transparent)
      Box(0, 0, imgbr, imghh, $FEFEFD)
      
      For j = 1 To fontanz
         DrawingFont(FontID(#font3))      
         DrawText(x, y , fontname(j), $002D00)
         DrawingFont(FontID(fontpbnr(j)))
         DrawText(x + minbr + 10, y, char$, $930000)
         charhh = TextHeight(char$) 
         Line(1, y + charhh + 2, imgbr - 8, 1, $EEEEEE)
         y + charhh + #abstand
      Next
      StopDrawing()
      
      For j = 1 To fontanz: FreeFont(fontpbnr(j)): Next
      
   EndIf   
   
   ;-Resizen
   ResizeGadget(#canvas, 0, 0, ImageWidth(#image2), ImageHeight(#image2))
   SetGadgetAttribute(#canvas, #PB_Canvas_Image, ImageID(#image2))
   
   ResizeGadget(#scroll, 0, 0, ImageWidth(#image2) + 21, WindowHeight(#window) - StatusBarHeight(#status))
   SetGadgetAttribute(#scroll, #PB_ScrollArea_InnerWidth, ImageWidth(#image2))
   SetGadgetAttribute(#scroll, #PB_ScrollArea_InnerHeight, ImageHeight(#image2))
   StatusBarText(#status, 2, "")

EndProcedure

Procedure.i EnumFontsProc(*lf.LOGFONT, *tm.TEXTMETRIC, fonttype, liste)
   
   AddGadgetItem(liste, -1, PeekS(@*lf\lfFaceName))
   
   ProcedureReturn #True
EndProcedure

Procedure.i EnumFonts(liste, name$)
   
   Protected dc = GetDC_(0)
   
   EnumFonts_(dc, 0, @EnumFontsProc(), liste)
   ReleaseDC_(0, dc)
   
   Protected j, anz = CountGadgetItems(liste) - 1   
   Protected Dim text$(anz)
   
   For j = 0 To anz: text$(j) = GetGadgetItemText(liste, j): Next   
   SortArray(text$(), #PB_Sort_Ascending )   
   ClearGadgetItems(liste)
   For j = 0 To anz
      AddGadgetItem(liste, -1, text$(j))      
      If text$(j) = name$: SetGadgetState(liste, j): EndIf
   Next
   
EndProcedure

Procedure.i Mainwindow()
   
   Protected fontname$ = "Arial" ;"Wingdings"   
   Protected fontsize  = 10  
   Protected fontstyle = 0
   
   LoadFont(#font0, "Arial", 9)  ;Font Button und Liste
   LoadFont(#font1, "Arial", 8)  ;Font AsciiNr im Image
   
   SetGadgetFont(#PB_Default, FontID(#font0)) 
   
   Protected j, event, mem
   
   Protected winbr = 700
   Protected winhh = 450
   Protected flags = #PB_Window_SystemMenu|#PB_Window_Invisible|#PB_Window_MinimizeGadget
   
   OpenWindow(#window, 150, 150, winbr, winhh, "Ascii - Tabelle", flags)
   CreateStatusBar(#status, WindowID(#window))
   AddStatusBarField(#PB_Ignore)
   AddStatusBarField(#PB_Ignore)
   AddStatusBarField(150)
   
   ScrollAreaGadget(#scroll, 0, 0, 0, 0, 0, 0)
   CanvasGadget(#canvas, 0, 0, 0, 0, #PB_Canvas_Border)
   CloseGadgetList()
   
   ContainerGadget(#container, 0, 0, 150, winhh - StatusBarHeight(#status), #PB_Container_Single)
   ListViewGadget(#liste, 2, 0, 146, winhh - 105)
   ComboBoxGadget(#combosize,  2, GadgetHeight(#liste) + 5, 145, 22)
   ComboBoxGadget(#combostyle, 2, GadgetHeight(#liste) + 30, 145, 22)
   CheckBoxGadget(#fontmuster, 2, GadgetHeight(#liste) + 55, 145, 22, "alle Fonts zeigen")
   For j = 6 To 18: AddGadgetItem(#combosize, -1, "Size " + Str(j)): Next
   AddGadgetItem(#combostyle, -1, "Normal")
   AddGadgetItem(#combostyle, -1, "Bold")
   AddGadgetItem(#combostyle, -1, "Italic")
   AddGadgetItem(#combostyle, -1, "Underline")
   AddGadgetItem(#combostyle, -1, "StrikeOut")
   CloseGadgetList()
   
   ;Infotext Combos, ab Vista
   CompilerIf #PB_Compiler_OS = #PB_OS_Windows
      Select OSVersion() 
         Case #PB_OS_Windows_Vista To #PB_OS_Windows_Future
            mem = AllocateMemory(60)
            PokeS(mem, "Fontsize ändern", -1, #PB_Unicode) 
            SendMessage_(GadgetID(#combosize), #CB_SETCUEBANNER, 0, mem)
            PokeS(mem, "Fontstyle ändern", -1, #PB_Unicode) 
            SendMessage_(GadgetID(#combostyle), #CB_SETCUEBANNER, 0, mem)
      EndSelect
   CompilerEndIf

   ;-Start   
   EnumFonts(#liste, fontname$)
   MakeImage(fontname$, fontsize, fontstyle)
   HideWindow(#window, 0)
   SetActiveGadget(#liste)
   
   Repeat: event = WaitWindowEvent()
      
      If event = #PB_Event_Gadget   
         
         Select EventGadget()
                              
            Case #liste
               fontname$ = GetGadgetItemText(#liste, GetGadgetState(#liste))
               MakeImage(fontname$, fontsize, fontstyle)
               
            Case #combosize
               fontsize = Val(Right(GetGadgetItemText(#combosize, GetGadgetState(#combosize)), 2))
               MakeImage(fontname$, fontsize, fontstyle)
               
            Case #combostyle
               Select GetGadgetState(#combostyle)
                  Case 1:  fontstyle = #PB_Font_Bold
                  Case 2:  fontstyle = #PB_Font_Italic
                  Case 3:  fontstyle = #PB_Font_Underline
                  Case 4:  fontstyle = #PB_Font_StrikeOut
                  Default: fontstyle = 0
               EndSelect
               MakeImage(fontname$, fontsize, fontstyle)
               
            Case #fontmuster
               If GetGadgetState(#fontmuster) = #PB_Checkbox_Checked
                  MakeImage2(fontsize, fontstyle)
               Else
                  MakeImage(fontname$, fontsize, fontstyle)                  
               EndIf
               
         EndSelect
         
      EndIf
      
   Until event = #PB_Event_CloseWindow 
   
EndProcedure

Mainwindow()

Re: meine Ascii Tabelle

Verfasst: 10.08.2012 22:37
von ts-soft
Sieht gut aus :allright:

aber warum von 032 - 287?
Ich erwarte eher von 000 - 255 oder bis 32767

Gruß
Thomas

Re: meine Ascii Tabelle

Verfasst: 10.08.2012 22:39
von RSBasic
ts-soft hat geschrieben:Sieht gut aus :allright:
*Mich anschließ*

Re: meine Ascii Tabelle

Verfasst: 11.08.2012 00:15
von STARGÅTE
ts-soft hat geschrieben:"aber warum von 032 - 287?"
Das liegt vermutlich daran, dass er oben "rows = 16"
übergibt, also 16*16 Zeichen gezeichnet werden sollen.
Da er aber bei 32 anfängt landet es bei 287^^

Kannst also gerne rows = 4096 angeben, dann meckert aber CreateImage ^^ wegen der gigantischen Höhe von 172000 Pixeln ^^

PS: Nette Zeichentabelle.

Wenn du wirklich auf Unicode erweitern solltest. Kannst du hiermit ermitteln, welche Zeichen die Font überhaupt enthält, und musst nicht alle 65.536 Zeichen zeichnen.
(Der Code geht nur dann über 255, wenn Unicode eingestellt ist)

Code: Alles auswählen

CompilerIf Defined(WCRANGE, #PB_Structure) = #Null
	Structure WCRANGE
		wcLow.u
		cGlyphs.u
	EndStructure
CompilerEndIf

CompilerIf Defined(GLYPHSET, #PB_Structure) = #Null
	Structure GLYPHSET
		cbThis.l
		flAccel.l
		cGlyphsSupported.l
		cRanges.l
		ranges.WCRANGE[0]
	EndStructure
CompilerEndIf


Global NewList FontCharacter.c()



Prototype.i GetFontUnicodeRanges(hdc.l, *gs.GLYPHSET)


Procedure.i ExamineFontCharacters(FontID.i)
	
	Protected Library = OpenLibrary(#PB_Any, "gdi32.dll")
	Protected GetFontUnicodeRanges.GetFontUnicodeRanges, Size.i
	Protected *DC = CreateCompatibleDC_(0)
	Protected *GlyphSet.GLYPHSET, Index, Character
	
	SelectObject_(*DC, FontID)
	ClearList(FontCharacter())
	
	If Library
		GetFontUnicodeRanges = GetFunction(Library,"GetFontUnicodeRanges")
		If GetFontUnicodeRanges
			Size = GetFontUnicodeRanges(*DC, #Null)
			If Size
				*GlyphSet = AllocateMemory(Size)
				If GetFontUnicodeRanges(*DC, *GlyphSet)
					For Index = 0 To *GlyphSet\cRanges-1
						For Character = 0 To *GlyphSet\ranges[Index]\cGlyphs
							If *GlyphSet\ranges[Index]\wcLow + Character < 1<<(8*SizeOf(Character))
								AddElement(FontCharacter())
								FontCharacter() = *GlyphSet\ranges[Index]\wcLow + Character
							EndIf
						Next
					Next
				EndIf
				FreeMemory(*GlyphSet)
			EndIf
		EndIf
		CloseLibrary(Library)
	EndIf
	
	DeleteDC_(*DC)
	ResetList(FontCharacter())
	
	ProcedureReturn ListSize(FontCharacter())
	
EndProcedure



Procedure.i NextFontCharacter()
	
	ProcedureReturn NextElement(FontCharacter())
	
EndProcedure



If ExamineFontCharacters(FontID(LoadFont(#PB_Any, "Courier New", 16)))
	While NextFontCharacter()
		Debug FontCharacter()
	Wend
EndIf
Quelle: Prüfen ob ein Zeichen in einer Font existiert

Re: meine Ascii Tabelle

Verfasst: 11.08.2012 07:42
von rolaf
ts-soft hat geschrieben:Sieht gut aus :allright:

aber warum von 032 - 287?
Ich erwarte eher von 000 - 255 oder bis 32767

Gruß
Thomas
Gibst du einfach

Code: Alles auswählen

Protected charnr = -1
statt

Code: Alles auswählen

Protected charnr = 31
ein und fertig ist der Zeichenbrei. :mrgreen:

Re: meine Ascii Tabelle

Verfasst: 13.08.2012 09:37
von dige
Sehr schön!
Alle Zeiten sind UTC+02:00
Seite 1 von 1

Powered by phpBB® Forum Software © phpBB Limited

Deutsche Übersetzung durch phpBB.de