posted March 07, 2006 01:55 PM            

#If 0                                                                     '
             Demo using arays for menus                                   '
   Code to use arrays for setting up Menu Bars using arrays.              '
   Can be convenient in some cases.                                       '
   The code below is out of Menus I added to EZ-Post(modified)            '
   (found here: http://www.SwedesDock.com/powerbasic/shortcuts.sht)       '
   Borje's Font MakeFontEx is included as well just for fun               '
#EndIf   
#Compile Exe
#Dim All
'
#Include "WIN32API.INC"
'
Declare  Sub Font_Set(ByRef id As Long)
%TB_Sample = 1000
'Menu array id's
%Fonts_Start       = 1101 
%Fonts_End         = 1125 
%Array_Options1_Ctl_Number_Start = 1126  
%Array_Options1_Ctl_Number_End   = 1150 
%Array_Options2_Ctl_Number_Start     = 1151
%Array_Options2_Ctl_Number_End       = 1175

' 
Type Parameters                                   
   Font_Name(25) As Asciiz * 50  'plenty room  
   Font_Size(25) As Long         
    Font_Ctl_Number(25) As Long         
   Array_Options1_Name(25) As Asciiz * 50  'plenty room  
    Array_Options1_Ctl_Number(25) As Long         
   Array_Options2_Name(25) As Asciiz * 50  
    Array_Options2_Ctl_Number(25) As Long         
End  Type                                         
Global Parm As Parameters                 
Global hDlg As Dword  'main handle
'
Macro Get_Textbox 
End Macro
' 
CallBack Function Hdlg_CB_Processor()
   Select Case CbMsg
     '  
     Case %WM_COMMAND
       Select Case CbCtl  
          ' 
          Case %Fonts_Start To %Fonts_End 
             Local id&
             id = CbCtl        
             Call Font_Set(id) 'font example
          ' 
          Case %Array_Options1_Ctl_Number_Start To %Array_Options1_Ctl_Number_end
              id = CbCtl - %Array_Options1_Ctl_Number_Start + 1
              MsgBox Parm.Array_Options1_Name(id),%mb_TaskModal, "Array 1 Options 1"
          '  
          Case %Array_Options2_Ctl_Number_Start To %Array_Options2_Ctl_Number_End 
              id = CbCtl - %Array_Options2_Ctl_Number_Start + 1
              MsgBox Parm.Array_Options2_Name(id),%mb_TaskModal, "Array 2 Options"
       End Select
   End Select
End Function

' 
Function PBMain
  Call Menus_Setup   
  ' GHL Added    
  Local Wid&, Hgt&  'show underneath Title & Status bar
  Wid             = 200                                                       
  Hgt             = 100                                                       
  Local n$  
  n$ = "Setup Menus using arrays"
   Dialog New hDlg, Space$(10) & n$, _
       0,0, _ 'center it
       Wid, Hgt,_
       %WS_CAPTION    Or _  'allows caption at top
       %WS_SYSMENU    Or _  '
       %DS_SysModal   Or _
       %WS_Ex_WindowEdge, _
       To hDlg 

    'create a menu bar
  Local hMenu As Dword
  Menu New Bar To hMenu 
    'now assign selection number to the menu 
  Local hPopUp1 As Dword, temp_pop As Dword
    Local x&, m$, id&, fnt$, s&, e&                           
  Menu New PopUp To hPopUp1                
    temp_pop = hPopup1 'for Cut&Paste convenience
     n$ = "&Font Change"
    ' Now give the menu some life (create it on the bar)
  Menu Add PopUp, hMenu, n$, temp_pop, %MF_ENABLED
    Reset x         
    s = %Fonts_Start 'for Cut&Paste convenience
    e = %Fonts_End
    For id& = s To e
       Incr x
       If Parm.Font_Ctl_Number(x) = > s And _
          Parm.Font_Ctl_Number(x) = < e Then 'assigned so add
           'Now add selections to the Menu   
          Menu Add String, temp_pop, Parm.Font_Name(x), id, %MF_ENABLED
       End If
    Next x
    'now let's add another to the menu 
  Local hPopUp2 As Dword
    temp_pop = hPopup2 'for Cut&Paste convenience
    n$ = "&Array1 Choices  " 
      s = %Array_Options1_Ctl_Number_Start
      e = %Array_Options1_Ctl_Number_End
  Menu New PopUp To temp_pop 
    ' Now give the menu some life (create it on the bar)
  Menu Add PopUp, hMenu, n$,  temp_pop, %MF_ENABLED
    Reset x         
    For id& = s To e
       Incr x
       If Parm.Array_Options1_Ctl_Number(x) = > s And _
          Parm.Array_Options1_Ctl_Number(x) = < e Then 'assigned so add
           'Now add selections to the Menu   
          Menu Add String, temp_pop, Parm.Array_Options1_Name(x), id, %MF_ENABLED
       End If
    Next x
    'now let's add another to the menu 
  Local hPopUp3 As Dword
    temp_pop = hPopup3 'for Cut&Paste convenience
    n$ = "A&rray 2 Choices" 
      s = %Array_Options2_Ctl_Number_Start
      e = %Array_Options2_Ctl_Number_End
  Menu New PopUp To temp_pop 
    ' Now give the menu some life (create it on the bar)
  Menu Add PopUp, hMenu, n$,  temp_pop, %MF_ENABLED
    Reset x         
    For id& = s To e
       Incr x  
       If Parm.Array_Options2_Ctl_Number(x) = > s And _
          Parm.Array_Options2_Ctl_Number(x) = < e Then 'assigned so add
           'Now add selections to the Menu   
          Menu Add String, temp_pop, Parm.Array_Options2_Name(x), id, %MF_ENABLED
       End If
    Next x

    ' attach the entire bar wih the menus to the dialog
   Menu Attach hMenu, hDlg
     
  Control Add TextBox, hDlg, %TB_sample, "Sample Textbox", _
     0, 0, _
     Wid - 30, Hgt - 15, _  
    %WS_CHILD Or %WS_VISIBLE Or %WS_BORDER Or %WS_TABSTOP Or _
    %WS_VSCROLL Or %ES_LEFT Or %ES_MULTILINE Or %ES_WANTRETURN, _
    %WS_EX_CLIENTEDGE Or %WS_EX_LEFT Or %WS_EX_LTRREADING Or _
    %WS_EX_RIGHTSCROLLBAR
   Dialog Show Modal hDlg    Call Hdlg_CB_Processor
End Function    
'              
' 
Sub Menus_Setup  
    Local x&, Start&
'do font codes here 
  Reset x 
  Start = %Fonts_Start
  Incr x: Parm.Font_Ctl_Number(x) = Start         
          Parm.Font_Size(x)  = 10
          Parm.Font_Name(x) = "Comic Sans MS (10)"
  Incr x: Parm.Font_Ctl_Number(x) = Start + x          
          Parm.Font_Size(x)  = 12
          Parm.Font_Name(x) = "Comic Sans MS (12)"
  Incr x: Parm.Font_Ctl_Number(x) = Start + x          
          Parm.Font_Size(x)  = 14
          Parm.Font_Name(x) = "Comic Sans MS (14)"
  Incr x: Parm.Font_Ctl_Number(x) = Start + x          
          Parm.Font_Size(x)  = 16
          Parm.Font_Name(x) = "Comic Sans MS (16)"
  Incr x: Parm.Font_Ctl_Number(x) = Start + x          
          Parm.Font_Size(x)  = 10
          Parm.Font_Name(x) = "Verdana (10)"
  Incr x: Parm.Font_Ctl_Number(x) = Start + x         
          Parm.Font_Size(x)  = 12
          Parm.Font_Name(x) = "Verdana (12)"
  Incr x: Parm.Font_Ctl_Number(x) = Start + x         
          Parm.Font_Size(x)  = 14
          Parm.Font_Name(x) = "Verdana (14)"
  Incr x: Parm.Font_Ctl_Number(x) = Start + x         
          Parm.Font_Size(x)  = 16
          Parm.Font_Name(x) = "Verdana (16)"
  Incr x: Parm.Font_Ctl_Number(x) = Start + x          
          Parm.Font_Size(x)  = 8
          Parm.Font_Name(x) = "Courier New (8)"
  Incr x: Parm.Font_Ctl_Number(x) = Start + x          
          Parm.Font_Size(x)  = 10
          Parm.Font_Name(x) = "Courier New (10)"
  Incr x: Parm.Font_Ctl_Number(x) = Start + x          
          Parm.Font_Size(x)  = 12
          Parm.Font_Name(x) = "Courier New (12)"
  Incr x: Parm.Font_Ctl_Number(x) = Start + x          
          Parm.Font_Size(x)  = 14
          Parm.Font_Name(x) = "Courier New (14)"
  Incr x: Parm.Font_Ctl_Number(x) = Start + x          
          Parm.Font_Size(x)  = 8
          Parm.Font_Name(x) = "Arial (8)"     
  Incr x: Parm.Font_Ctl_Number(x) = Start + x          
          Parm.Font_Size(x)  = 10
          Parm.Font_Name(x) = "Arial (10)"
  Incr x: Parm.Font_Ctl_Number(x) = Start + x          
          Parm.Font_Size(x)  = 12
          Parm.Font_Name(x) = "Arial (12)"
  Incr x: Parm.Font_Ctl_Number(x) = Start + x          
          Parm.Font_Size(x)  = 14
          Parm.Font_Name(x) = "Arial (14)"

'do Array_Options1 codes here as well
  Local Ctl_Number& 
  Ctl_Number = %Array_Options1_Ctl_Number_Start
   For x = 1 To 15 'only 15 options for demo
      Parm.Array_Options1_Ctl_Number(x) = Ctl_Number
      Parm.Array_Options1_Name(x) = Using$("Array1 Choice (#) ", x)
      Incr Ctl_Number
   Next x     
'do Array_Options1 codes here as well
  Ctl_Number = %Array_Options2_Ctl_Number_Start
   For x = 1 To 15 'only 15 options for demo
      Parm.Array_Options2_Ctl_Number(x) = Ctl_Number
      Parm.Array_Options2_Name(x) = Using$("Array2 Choice (#) ", x)
      Incr Ctl_Number
   Next x     
End Sub
'
Function MakeFontEx(ByVal FontName As String, _
                    ByVal PointSize As Long, _
                    ByVal fBold As Long, _
                    ByVal fItalic As Long, _
                    ByVal fUnderline As Long) As Long
 
  ' Borrowed from Borje Hagsten
  ' MakeFontEx(FontName, PointSize, fBold, fItalic, fUnderline)
 
  Local hDC As Long, CyPixels As Long
 
  hDC = GetDC(%HWND_DESKTOP)
  CyPixels  = GetDeviceCaps(hDC, %LOGPIXELSY)
  ReleaseDC %HWND_DESKTOP, hDC
  PointSize = 0 - (PointSize * CyPixels) \ 72
 
  Function = CreateFont( _
             PointSize, 0, _        'height, width(default=0)
             0, 0, _                'escapement(angle), orientation
             fBold, _               'weight (%FW_DONTCARE = 0, %FW_NORMAL = 400, %FW_BOLD = 700)
             fItalic, _             'Italic
             fUnderline, _          'Underline
             %FALSE, _              'StrikeThru - who needs it?
             %ANSI_CHARSET, %OUT_TT_PRECIS, _
             %CLIP_DEFAULT_PRECIS, %DEFAULT_QUALITY, _
             %FF_DONTCARE , ByCopy FontName)
 
End Function
'
' 
Sub Font_Set(id  As Long)
 Local fnt$, fsze&, x&
  id = id - %Fonts_Start + 1 'start array count (1 to 25)
  If id >= 1 And id =< 25 Then  'within range set in Parm.
    fsze = Parm.Font_Size(id)
    fnt$ = Parm.Font_Name(id)
     Local i&
     i = InStr(fnt$, "(")
     If i Then 'name exists so strip out extra stuff
        fnt$ = Left$(Fnt$, i-1)
          'create the new font
          Local hFont& 'Fnt_Sze&
          hFont = MakefontEx(Fnt$, fsze, %FW_BOLD, %FALSE, %FALSE)
          Control Send hdlg, %TB_Sample, %WM_SETFONT, hFont, 0
           'just show the selected font name for fun
           Local t$
           Control Get Text hdlg, %TB_Sample To t$ 
            t$ = t$ & $CrLf & Parm.Font_Name(id)
           Control Set Text hdlg, %TB_Sample, t$ 
           Control ReDraw hdlg, %TB_Sample
        
       Else 'error
        MsgBox fnt$, %MB_TASKMODAL, "Font Error" 
     End If 'end instr check   
    Else
     MsgBox Using$("# Control sent", id), %MB_TASKMODAL, "Font Range Error" 
  End If 'end range check  
End Sub                   
'
'