! This software SHOWFONT.F90 is part of the Compaq Visual Fortran kit.
! 
! This software is provided as an example that demonstrates a particular
! feature/function of the licensed product. The software is not intended to
! provide a complete solution to any application problem but rather is provided
! as a teaching mechanism.
! 
! Users may incorporate any part of this sample into their own source after 
! making appropriate changes to make it suitable for the intended application.
!
! This sample program demonstrates a "dialog-based" Fortran application using
! the Visual Fortran Dialog Functions.  The main window of the application
! is a dialog box.  This program demonstrates the use of a Tab control.
! The Tab control is used to select the properties of a font.  The font is used
! to display a sample text string.
!
! The basic structure of this application was generated using the Fortran
! Windows Application project wizard.
!
!
!  ShowFont.f90 
!
!  FUNCTIONS:
!	WinMain()			- Entry point for the application;
!						  displays the main window; processes the message loop
!	ShowFontSub()		- Callback routine for the main dialog box
!	FamilySub()			- Callback routine for the Family tab dialog box
!	StyleSub()			- Callback routine for the Style tab dialog box
!   EnumFamiliesProc()	- Callback routine for font enumeration
!   EnumFamilyProc()	- Callback routine for font enumeration
!   ChangeFamily()      - Callback routine when a font family is selected
!	ChangeTabSub()		- Callback routine for changing tabs
!   UpdateFont()        - Callback routine when the Edit box font should
!                         be updated
!

!****************************************************************************
!
!  FUNCTION: WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow )
!
!  PURPOSE:  Entry point for the application
!
!  COMMENTS: Displays the main window and processes the message loop
!
!****************************************************************************

integer*4 function WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow )
!DEC$ IF DEFINED(_X86_)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_WinMain@16' :: WinMain
!DEC$ ELSE
!DEC$ ATTRIBUTES STDCALL, ALIAS : 'WinMain' :: WinMain
!DEC$ ENDIF

	use dfwin
	use dflogm
	use showfontGlobals

	implicit none

	integer*4 hInstance
	integer*4 hPrevInstance
	integer*4 lpszCmdLine
	integer*4 nCmdShow

	include 'resource.fd'

	external ShowFontSub
	external FamilySub
	external StyleSub
	external ChangeFamily
	external UpdateFont
	external ChangeTabSub

	! Variables
	type (T_MSG)            mesg
	integer*4			    ret
	integer*4			    hwnd
	logical*4				lret


	ghInstance = hInstance
	ghModule = GetModuleHandle(NULL)
	ghFont = NULL

	!  Initialize the main dialog box
	lret = DlgInit(IDD_SHOWFONT_DIALOG, gdlg)
	lret = DlgSetSub(gdlg, IDD_SHOWFONT_DIALOG, ShowFontSub)
	lret = DlgSetSub(gdlg, IDC_TAB, ChangeTabSub)
	lret = DlgSet(gdlg, IDC_EDIT, "AaBbCcXxYyZz")

	!  Set initial tabs
	lret = DlgSet(gdlg, IDC_TAB, 3)
	lret = DlgSet(gdlg, IDC_TAB, "Family", 1)
	lret = DlgSet(gdlg, IDC_TAB, "Style", 2)
	lret = DlgSet(gdlg, IDC_TAB, "Size", 3)
	lret = DlgSet(gdlg, IDC_TAB, IDD_TAB_DIALOG1, 1)
	lret = DlgSet(gdlg, IDC_TAB, IDD_TAB_DIALOG2, 2)
	lret = DlgSet(gdlg, IDC_TAB, IDD_TAB_DIALOG3, 3)

	!  Initialize the tab dialog boxes
	lret = DlgInit(IDD_TAB_DIALOG1,  gdlg_tab1)
	lret = DlgSetSub(gdlg_tab1, IDD_TAB_DIALOG1, FamilySub)
	lret = DlgSetSub(gdlg_tab1, IDC_FAMILY_LIST, ChangeFamily)
	lret = DlgInit(IDD_TAB_DIALOG2,  gdlg_tab2)
	lret = DlgSetSub(gdlg_tab2, IDD_TAB_DIALOG2, StyleSub)
	lret = DlgSetSub(gdlg_tab2, IDC_STYLE_LIST, UpdateFont)
	lret = DlgInit(IDD_TAB_DIALOG3,  gdlg_tab3)
	lret = DlgSetSub(gdlg_tab3, IDC_SIZE_LIST, UpdateFont)

	lret = DlgModeless(gdlg, nCmdShow)

	! Read and process messsages
	do while( GetMessage (mesg, NULL, 0, 0) ) 
	   ! Note that DlgIsDlgMessage must be called in order to give
	   ! the dialog box first chance at the message.
	   if ( DlgIsDlgMessage(mesg) .EQV. .FALSE. ) then
		   lret = TranslateMessage( mesg )
		   ret  = DispatchMessage( mesg )
	   end if
	end do

	! Cleanup dialog box memory
	call DlgUninit(gdlg)
	call DlgUninit(gdlg_tab1)
	call DlgUninit(gdlg_tab2)
	call DlgUninit(gdlg_tab3)

	WinMain = mesg.wParam
	return

99999 &

	ret = MessageBox(ghwndMain, "Error initializing application ShowFont"C, &
					 "Error"C, MB_OK)
	WinMain = 0

end 

!****************************************************************************
!
!  FUNCTION: ShowFontSub ( dlg, id, callbacktype )
!
!  PURPOSE:  Main dialog box callback for initialization and destroy
!
!  COMMENTS:
!
!****************************************************************************

SUBROUTINE ShowFontSub( dlg, id, callbacktype )
!DEC$ ATTRIBUTES DEFAULT :: ShowFontSub

  use dfwin
  use dflogm
  use showfontGlobals

  implicit none

  include 'resource.fd'

  type (dialog) dlg
  integer id, callbacktype
  integer hwnd
  logical lret

  ! When the Main dialog box is first displayed, call DlgModeless to
  ! display the tab dialog boxes.  Note the use of SW_HIDE.  The
  ! Dialog Functions will "show" the proper tab dialog box.
  if (callbacktype == dlg_init) then
	hwnd = GetDlgItem(dlg % hwnd, IDC_TAB)
	lret = DlgModeless(gdlg_tab1, SW_HIDE, hwnd)
	lret = DlgModeless(gdlg_tab2, SW_HIDE, hwnd)
	lret = DlgModeless(gdlg_tab3, SW_HIDE, hwnd)

	! Note that we must set the default tab after the calls to
	! DlgModeless.  Otherwise, no tab dialog box will be displayed
	! initially.
	lret = DlgSet(dlg, IDC_TAB, 1, dlg_state)

 	call ChangeFamily(gdlg_tab1, IDC_FAMILY_LIST, DLG_SELCHANGE)

  ! When the user presses the "Exit" button, the default callback
  ! calls DLGEXIT which calls this callback with 
  ! callbacktype == dlg_destroy.  We call PostQuitMessage to cause
  ! the message loop in WinMain to terminate.
  else if (callbacktype == dlg_destroy) then
	call PostQuitMessage(0)
  endif

  END SUBROUTINE ShowFontSub

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! CopyCStr
!!
!! Copies a null terminated C string to a F90 string
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine CopyCStr( cstr, fstr )
  byte, dimension(*), intent(in)  :: cstr
  character*(*), intent(out) :: fstr

    integer i
	! scan up to the terminating null
	i = 1
	do while( cstr(i) .ne. 0 )
	  fstr(i:i) = CHAR(cstr(i))
	  i = i + 1
	end do
    ! pad the rest with blanks
	do while( i .le. len(fstr) )
	  fstr(i:i) = ' '
	  i = i + 1
	end do
end subroutine CopyCStr

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! CopyFStr
!!
!! Copies a F90 string to a null terminated C string
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine CopyFStr( fstr, cstr )
  character*(*), intent(in)  :: fstr
  character*(*), intent(out) :: cstr

	!  Search for the last non-blank character in the F90 string
	!  and replace the next character with a terminating 0
	integer l
	l = len_trim(fstr)
	if (l > 0) then
		cstr(:l) = fstr(:l)
	end if 
	cstr(l+1:l+1) = char(0)
end subroutine CopyFStr

!****************************************************************************
!
!  FUNCTION: EnumFamiliesProc ( )
!
!  PURPOSE:  Call once for each font family
!
!  COMMENTS: We use this to fill the "Family" list box
!
!****************************************************************************

integer*4 FUNCTION EnumFamiliesProc( pEnumLogFont, pNewTextMetric, fontType, lParam )
!DEC$ IF DEFINED(_X86_)
!DEC$ ATTRIBUTES STDCALL, ALIAS : "_ENUMFAMILIESPROC" :: EnumFamiliesProc
!DEC$ ELSE
!DEC$ ATTRIBUTES STDCALL, ALIAS : "ENUMFAMILIESPROC" :: EnumFamiliesProc
!DEC$ ENDIF

  use dfwin
  use dflogm
  use showfontGlobals

  implicit none

  include 'resource.fd'

  pointer(pEnumLogFont, logFont)
  pointer(pNewTextMetric, textMetric)
  integer fontType
  integer lParam

  type (T_ENUMLOGFONT) logFont
  type (T_NEWTEXTMETRIC) textMetric

  integer index, iret
  logical lret
  character*(LF_FACESIZE) faceName
  character*(LF_FACESIZE) tempName
  byte lfFaceName (LF_FACESIZE )
  equivalence(tempName, lfFaceName)

  type (T_LOGFONT) lfCopy
  pointer(plf, lfCopy)
  
  EnumFamiliesProc = 1

  !  We ignore fonts of type DEVICE_FONTTYPE
  if ((fontType .AND. DEVICE_FONTTYPE) .ne. 0) then
 	return
  end if

  !  Add an entry to the list box for this family
  lret = DlgGet(gdlg_tab1, IDC_FAMILY_LIST, index)
  if (index == MAX_FONTS) return
  tempName = logFont % elfLogFont % lfFaceName
  call CopyCStr(lfFaceName, faceName)
  index = index + 1
  lret = DlgSet(gdlg_tab1, IDC_FAMILY_LIST, index)
  lret = DlgSet(gdlg_tab1, IDC_FAMILY_LIST, faceName, index)

  !  Make a copy of the T_LOGFONT structure to use in the call to 
  !  CreateFont when the user requests this font
  plf = MALLOC(sizeof(lfCopy))
  lfCopy = logFont % elfLogFont
  gLogFonts(index) = plf

  END FUNCTION EnumFamiliesProc

!****************************************************************************
!
!  FUNCTION: EnumFamilyProc ( )
!
!  PURPOSE:  Call once for each font in a family
!
!  COMMENTS: We use this to fill the "Size" list box
!
!****************************************************************************

integer*4 FUNCTION EnumFamilyProc( pEnumLogFont, pNewTextMetric, fontType, lParam )
!DEC$ IF DEFINED(_X86_)
!DEC$ ATTRIBUTES STDCALL, ALIAS : "_ENUMFAMILYPROC" :: EnumFamilyProc
!DEC$ ELSE
!DEC$ ATTRIBUTES STDCALL, ALIAS : "ENUMFAMILYPROC" :: EnumFamilyProc
!DEC$ ENDIF

  use dfwin
  use dflogm
  use showfontGlobals

  implicit none

  include 'resource.fd'

  pointer(pEnumLogFont, logFont)
  pointer(pNewTextMetric, textMetric)
  integer fontType
  integer lParam

  type (T_ENUMLOGFONT) logFont
  type (T_NEWTEXTMETRIC) textMetric

  integer index, height, pointSize, iTemp, iret
  integer hdc
  logical lret
  character*(2) size
  character*(2) item

  EnumFamilyProc = 2

  !  We ignore fonts of type DEVICE_FONTTYPE
  if ((fontType .AND. DEVICE_FONTTYPE) .ne. 0) then
 	return
  end if

  !  Get the number of entries in the size list
  lret = DlgGet(gdlg_tab3, IDC_SIZE_LIST, index)

  !  For a TRUETYPE font, add a standard set of sizes
  if ((fontType .AND. TRUETYPE_FONTTYPE) .ne. 0) then
	  if (index == 0) then
		  lret = DlgSet(gdlg_tab3, IDC_SIZE_LIST, " 6", DLG_ADDSTRING)
		  lret = DlgSet(gdlg_tab3, IDC_SIZE_LIST, " 8", DLG_ADDSTRING)
		  lret = DlgSet(gdlg_tab3, IDC_SIZE_LIST, "10", DLG_ADDSTRING)
		  lret = DlgSet(gdlg_tab3, IDC_SIZE_LIST, "12", DLG_ADDSTRING)
		  lret = DlgSet(gdlg_tab3, IDC_SIZE_LIST, "14", DLG_ADDSTRING)
		  lret = DlgSet(gdlg_tab3, IDC_SIZE_LIST, "16", DLG_ADDSTRING)
		  lret = DlgSet(gdlg_tab3, IDC_SIZE_LIST, "18", DLG_ADDSTRING)
		  lret = DlgSet(gdlg_tab3, IDC_SIZE_LIST, "20", DLG_ADDSTRING)
		  lret = DlgSet(gdlg_tab3, IDC_SIZE_LIST, "22", DLG_ADDSTRING)
		  lret = DlgSet(gdlg_tab3, IDC_SIZE_LIST, "24", DLG_ADDSTRING)
	  end if
	  return
  end if

  !  This must be a raster font.
  !  Add an entry to the size list box for this family 
  height = logFont % elfLogFont % lfHeight
  hdc = GetDC(NULL)
  iTemp = GetDeviceCaps(hdc, LOGPIXELSY)
  pointSize = height * 72 / iTemp
  write(size, "(I2)") pointSize
  iret = ReleaseDC(NULL, hdc)

  !  Determine if this size is already in the list
  do iTemp = 1, index
	  lret = DlgGet(gdlg_tab3, IDC_SIZE_LIST, item, iTemp)
	  if (size == item) then
			return
	  end if
  end do 

  lret = DlgSet(gdlg_tab3, IDC_SIZE_LIST, size, DLG_ADDSTRING)

  END FUNCTION EnumFamilyProc

!****************************************************************************
!
!  FUNCTION: FamilySub ( dlg, id, callbacktype )
!
!  PURPOSE:  Dialog box callback for initialization and destroy
!
!  COMMENTS:
!
!****************************************************************************

SUBROUTINE FamilySub( dlg, id, callbacktype )
!DEC$ ATTRIBUTES DEFAULT :: FamilySub

  use dfwin
  use dflogm
  use showfontGlobals

  implicit none

  include 'resource.fd'

  external EnumFamiliesProc

  type (dialog) dlg
  integer id, callbacktype

  logical lret
  integer iret, lparam, hdc, i

  if (callbacktype == dlg_init) then
		!  Fill the "family" list box
		hdc = GetDC(NULL)
        lparam = 0
		iret = EnumAllFontFamilies (hdc, NULL, loc(EnumFamiliesProc), lparam) 
		iret = ReleaseDC(NULL, hdc)
		!  Choose a default font; the first entry
	    lret = DlgSet(gdlg_tab1, IDC_FAMILY_LIST, 1, 1)
	    lret = DlgSet(gdlg_tab1, IDC_FAMILY_LIST, 0, 2)
  else if (callbacktype == dlg_destroy) then
		!  Free the T_LOGFONT structures that are associated with the items
		!  in the list
	    lret = DlgGet(gdlg_tab1, IDC_FAMILY_LIST, iret)
		do i=1,iret
		  call FREE(gLogFonts(i))
		end do
  end if

  END SUBROUTINE FamilySub


!****************************************************************************
!
!  FUNCTION: StyleSub ( dlg, id, callbacktype )
!
!  PURPOSE:  Dialog box callback for initialization and destroy
!
!  COMMENTS:
!
!****************************************************************************

SUBROUTINE StyleSub( dlg, id, callbacktype )
!DEC$ ATTRIBUTES DEFAULT :: StyleSub

  use dfwin
  use dflogm
  use showfontGlobals

  implicit none

  include 'resource.fd'

  type (dialog) dlg
  integer id, callbacktype

  logical lret
  integer iret, lparam, hdc

  if (callbacktype == dlg_init) then
	  !  Fill the "style" list box
	  lret = DlgSet(gdlg_tab2, IDC_STYLE_LIST, 4)
	  lret = DlgSet(gdlg_tab2, IDC_STYLE_LIST, "Regular", 1)
	  lret = DlgSet(gdlg_tab2, IDC_STYLE_LIST, "Italic", 2)
	  lret = DlgSet(gdlg_tab2, IDC_STYLE_LIST, "Bold", 3)
	  lret = DlgSet(gdlg_tab2, IDC_STYLE_LIST, "Bold Italic", 4)
	  !  Choose a default style (Regular)
	  lret = DlgSet(gdlg_tab2, IDC_STYLE_LIST, 1, 1)
	  lret = DlgSet(gdlg_tab2, IDC_STYLE_LIST, 0, 2)
  end if

  END SUBROUTINE StyleSub

!****************************************************************************
!
!  FUNCTION: ChangeTabSub ( dlg, id, callbacktype )
!
!  PURPOSE:  Callback when a tab is selected
!
!  COMMENTS:
!
!****************************************************************************

SUBROUTINE ChangeTabSub( dlg, id, callbacktype )
!DEC$ ATTRIBUTES DEFAULT :: ChangeTabSub

  use dfwin
  use dflogm
  use showfontGlobals

  implicit none

  include 'resource.fd'

  type (dialog) dlg
  integer id, callbacktype

  logical lret
  integer iTab, idTab, hwnd

  !  Set the window focus to the list box of the selected tab dialog box
  lret = DlgGet(dlg, id, iTab, dlg_state)
  lret = DlgGet(dlg, id, idTab, iTab)
  select case (idTab)
      case (IDD_TAB_DIALOG1) 
		hwnd = GetDlgItem(gdlg_tab1 % hwnd, IDC_FAMILY_LIST)
      case (IDD_TAB_DIALOG2) 
		hwnd = GetDlgItem(gdlg_tab2 % hwnd, IDC_STYLE_LIST)
      case (IDD_TAB_DIALOG3) 
		hwnd = GetDlgItem(gdlg_tab3 % hwnd, IDC_SIZE_LIST)
  end select
  hwnd = SetFocus(hwnd)

  END SUBROUTINE ChangeTabSub

!****************************************************************************
!
!  FUNCTION: ChangeFamily ( dlg, id, callbacktype )
!
!  PURPOSE:  Callback when a font family is selected
!
!  COMMENTS:
!
!****************************************************************************

SUBROUTINE ChangeFamily( dlg, id, callbacktype )
!DEC$ ATTRIBUTES DEFAULT :: ChangeFamily

  use dfwin
  use dflogm
  use showfontGlobals

  implicit none

  include 'resource.fd'

  external EnumFamilyProc

  type (dialog) dlg
  integer id, callbacktype
  
  character*(LF_FACESIZE) faceName
  character*(LF_FACESIZE) cFaceName
  character*(2) size
  character*(2) item
  logical lret
  integer iret, hdc, pointSize, lparam, iTemp, iSize, index

  !  Fill the list box with the valid sizes for this font
  lret = DlgGet(gdlg_tab3, IDC_SIZE_LIST, size, dlg_state)
  read(size, "(I2)") pointSize
  lret = DlgGet(gdlg_tab1, IDC_FAMILY_LIST, faceName, dlg_state)
  call CopyFStr(faceName, cFaceName)
  lret = DlgSet(gdlg_tab3, IDC_SIZE_LIST, 0)
  hdc = GetDC(NULL)
  lparam = 0
  iret = EnumFontFamilies (hdc, cFaceName, loc(EnumFamilyProc), lparam) 
  iret = ReleaseDC(NULL, hdc)

  !  Choose a default size; Use the same size as the previous font;
  !  If not available, use the first entry
  lret = DlgGet(gdlg_tab3, IDC_SIZE_LIST, index)
  iSize = 1
  do iTemp = 1, index
	  lret = DlgGet(gdlg_tab3, IDC_SIZE_LIST, item, iTemp)
	  if (size == item) then
			iSize = iTemp
			exit
	  end if
  end do 
  lret = DlgSet(gdlg_tab3, IDC_SIZE_LIST, iSize, 1)
  lret = DlgSet(gdlg_tab3, IDC_SIZE_LIST, 0, 2)

  !  Update the font in the Edit box
  call UpdateFont(gdlg_tab2, IDC_STYLE_LIST, DLG_SELCHANGE)

  END SUBROUTINE ChangeFamily

!****************************************************************************
!
!  FUNCTION: UpdateFont ( dlg, id, callbacktype )
!
!  PURPOSE:  Updates the fon in the Edit box
!
!  COMMENTS:
!
!****************************************************************************

SUBROUTINE UpdateFont( dlg, id, callbacktype )
!DEC$ ATTRIBUTES DEFAULT :: UpdateFont

  use dfwin
  use dflogm
  use showfontGlobals

  implicit none

  include 'resource.fd'

  type (dialog) dlg
  integer id, callbacktype
  
  logical lret
  integer iret
  integer i, iFamily, iStyle
  character*(LF_FACESIZE) faceName
  character*(LF_FACESIZE) tempName
  byte byteFaceName (LF_FACESIZE )
  pointer(pbfn, byteFaceName)
  character*(5) size
  integer hOldFont, hdc
  integer weight, pointSize, iTemp
  logical italic

  type (T_LOGFONT) lf
  pointer(plf, lf)
  
  !  Get the current font selections
  lret = DlgGet(gdlg_tab1, IDC_FAMILY_LIST, faceName, dlg_state)
  lret = DlgGet(gdlg_tab2, IDC_STYLE_LIST,  iStyle, 1)
  select case (iStyle)
      case (1) 
			   weight = 400			! Regular
			   italic = .FALSE.
      case (2) 
	           weight = 400			! Italic
			   italic = .TRUE.
      case (3) 
	           weight = 700			! Bold
			   italic = .FALSE.
      case (4) 
	           weight = 700			! Bold Italic
			   italic = .TRUE.
  end select
  lret = DlgGet(gdlg_tab3, IDC_SIZE_LIST, size, dlg_state)
  read(size, "(I2)") pointSize

  hOldFont = ghFont

  !  Create a font object
  !  First, find the T_LOGFONT structure that matches this face name
  lret = DlgGet(gdlg_tab1, IDC_FAMILY_LIST, iret)
  do i=1,iret
	plf = gLogFonts(i)
	pbfn = loc(lf % lfFaceName)
	call CopyCStr(byteFaceName, tempName)
	if (faceName == tempName) exit
  end do
  
  !  Set the point-size and display attributes
  hdc = GetDC(NULL)
  iTemp = GetDeviceCaps(hdc, LOGPIXELSY)
  lf % lfHeight = -MulDiv(pointSize, iTemp, 72)
  lf % lfWeight = weight
  lf % lfWidth = 0
  if (italic) then
	lf % lfItalic = 1
  else
	lf % lfItalic = 0
  end if
  ghFont = CreateFontIndirect(lf)

  if (ghFont .ne. NULL) then
	iret = DlgSendCtrlMessage(gdlg, IDC_EDIT, WM_SETFONT, ghFont, 1)
	!  Delete the old font
	if (hOldFont .ne. NULL) then
		iret = DeleteObject(hOldFont)
	end if
  end if

  iret = ReleaseDC(NULL, hdc)

  END SUBROUTINE UpdateFont
