Newsgroup: it.comp.os.win.software
Titolo: EXCEL - elenco font

ciao a tutti .
c'e' qulache possibilita' in excel di stampare un esempio per ogni
font che c'e nel PC ?
tipo :
Dim Stringa As String
Stringa = "Prova"
Dim a As Object
Range("A1").Select
For Each a In Application.Fonts  '(*)
  With Selection
    .Value = a.Name
    .Offset(0, 1).Value = Stringa
    .Font.Name = a
  End With
Next a
(*)  e' questa che non gira.
grazie e buon anno
Antonio
(togliere NO SPaM per rispondere)


Newsgroups: it.comp.lang.visual-basic
Subject: [API] Raccolta API V 1_10
Date: Sat, 30 Dec 2000 16:11:14 +0100
Nuovi aggiornamenti funzioni API su 
http://members.xoom.it/CesareRizzi
 dove
puoi scaricare la guida API in italiano in formato CHM
[...]
Questa volta, ho pensato ai Font
La Raccolta API si arricchisce con le seguenti funzioni della libreria
GDI32.dll
EnumFonts : Enumerare i Font Installati nel sistema
CreateFontIndirect : Crearre Font partendo dagli attributi logici
ExtTextOut : Manipoliamo stringhe di testo
[...]
ATTENZIONE, Da un po' di tempo ho difficoltà negli aggiornamenti,, in caso
di problemi trovate esattamente tutto su 
http://space.tin.it/clubnet/kxrizz
--
Ciao.
Maurizio
--------
?SPQR(C)
 X
--------




 me lo studio un po', penso comunque faccia uso delle API vedo se riesco a
tradurlo in Excel.
Nel frattempo ho buttato giu` un piccolo test:
A1: =GetFontName(A2)
A2: ABCDEFGHIJKLM
A3: NOPQRSTUVWXYZ
B2: abcdefghijklm
B3: nopqrstuvwxyz
C2: '0123456789
' Modulo: MUserFunctions
'
Option Explicit
Public Function GetFontName( _
  ByVal Target As Excel.Range _
) As String
  Excel.Application.Volatile
  GetFontName = 
Target.Font.Name
End Function
Poi selezioni A2:C3 e lanci la macro seguente:
' Modulo: MMain
'
Option Explicit
Public Sub ShowAllFonts( _
)
  Dim strFonts()  As String
  Dim strFont     As Variant
  With Excel.Application
    strFonts = GetFonts(GetDcByCaption(.Caption))
    For Each strFont In strFonts
      'Debug.Print strFont
      .ScreenUpdating = False
      .
Selection.Font.Name
 = strFont
      .Calculate
      .ScreenUpdating = True
      .Wait Now + TimeSerial(0, 0, 2)
    Next
  End With
End Sub
' Modulo: MFonts
'
Option Explicit
Private Const LF_FACESIZE = 32
' typedef struct tagLOGFONT { // lf
'   LONG lfHeight;
'   LONG lfWidth;
'   LONG lfEscapement;
'   LONG lfOrientation;
'   LONG lfWeight;
'   BYTE lfItalic;
'   BYTE lfUnderline;
'   BYTE lfStrikeOut;
'   BYTE lfCharSet;
'   BYTE lfOutPrecision;
'   BYTE lfClipPrecision;
'   BYTE lfQuality;
'   BYTE lfPitchAndFamily;
'   TCHAR lfFaceName[LF_FACESIZE];
' } LOGFONT;
Private Type LOGFONT
  lfHeight                As Long
  lfWidth                 As Long
  lfEscapement            As Long
  lfOrientation           As Long
  lfWeight                As Long
  lfItalic                As Byte
  lfUnderline             As Byte
  lfStrikeOut             As Byte
  lfCharSet               As Byte
  lfOutPrecision          As Byte
  lfClipPrecision         As Byte
  lfQuality               As Byte
  lfPitchAndFamily        As Byte
  lfFaceName(LF_FACESIZE) As Byte
End Type
' int EnumFonts(
'   HDC           hdc,        // handle to device context
'   LPCTSTR       lpFaceName, // pointer to font typeface
'                             //    name string
'   FONTENUMPROC  lpFontFunc, // pointer to callback function
'   LPARAM        lParam      // address of
'                             //    application-supplied data
' );
Private Declare Function EnumFonts _
  Lib "gdi32.dll" Alias "EnumFontsA" ( _
    ByVal hDC As Long _
  , ByVal lpsz As String _
  , ByVal lpFontEnumProc As Long _
  , ByVal lParam As Long _
  ) As Long
' BOOL EnumWindows(
'   WNDENUMPROC lpEnumFunc, // pointer to callback function
'   LPARAM      lParam      // application-defined value
' );
Private Declare Function EnumWindows _
  Lib "user32.dll" ( _
    ByVal lpEnumFunc As Long _
  , ByVal lParam As Long _
  ) As Long
Private Declare Sub CopyMemory _
  Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
    pDst As Any _
  , pSrc As Any _
  , ByVal ByteLen As Long)
' HWND GetDesktopWindow(VOID)
Private Declare Function GetDesktopWindow _
  Lib "user32.dll" ( _
  ) As Long
' HDC GetDC(
'   HWND hWnd // handle of window
' );
Private Declare Function GetDC _
  Lib "user32.dll" ( _
    ByVal hWnd As Long _
  ) As Long
Private Const WM_GETTEXT = &HD
' LRESULT SendMessage(
'   HWND hWnd,      // handle of destination window
'   UINT Msg,       // message to send
'   WPARAM wParam,  // first message parameter
'   LPARAM lParam   // second message parameter
' );
Private Declare Function SendMessage _
  Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hWnd As Long _
  , ByVal wMsg As Long _
  , ByVal wParam As Long _
  , ByVal lParam As Any _
  ) As Long
Private m_strCaption  As String
Private m_strFonts    As String
Private m_lngHDC      As Long
Public Function GetDcByCaption( _
  ByVal Caption As String _
) As Long
  m_strCaption = Caption
  EnumWindows AddressOf EnumWindowsProc, 0&
  GetDcByCaption = m_lngHDC
End Function
Public Function GetFonts( _
  Optional ByVal hDC As Variant _
) As String()
  Dim lngHandle As Long
  GetFonts = Split("")
  If IsMissing(hDC) Then
    lngHandle = GetDC(GetDesktopWindow)
  Else
    If VarType(hDC) = vbLong _
    Then _
      lngHandle = hDC
  End If
  EnumFonts _
      lngHandle _
    , vbNullString _
    , AddressOf EnumFontsProc _
    , 0&
  GetFonts = Split(m_strFonts, vbTab)
End Function
' int CALLBACK EnumFontsProc(
'   lplf    lplf,   // pointer to logical-font data
'   lptm    lptm,   // pointer to physical-font data
'   DWORD   dwType, // font type
'   LPARAM  lpData  // pointer to application-defined data
' );
Private Function EnumFontsProc( _
  ByVal lplf As Long _
, ByVal lptm As Long _
, ByVal dwType As Long _
, ByVal lpData As Long _
) As Long
On Error Resume Next
  Dim LF        As LOGFONT
  Dim FontName  As String
  Dim ZeroPos   As Long
  CopyMemory LF, ByVal lplf, LenB(LF)
  FontName = StrConv(LF.lfFaceName, vbUnicode)
  ZeroPos = InStr(1, FontName, Chr$(0))
  If ZeroPos Then FontName = Left$(FontName, ZeroPos - 1)
  If Len(m_strFonts) Then
    m_strFonts = m_strFonts & vbTab & FontName
  Else
    m_strFonts = FontName
  End If
  EnumFontsProc = 1&
End Function
' BOOL CALLBACK EnumWindowsProc(
'   HWND   hWnd,    // handle to parent window
'   LPARAM lParam   // application-defined value
' );
Private Function EnumWindowsProc( _
  ByVal hWnd As Long _
, ByVal lParam As Long _
) As Long
On Error Resume Next
  Dim strBuffer As String
  EnumWindowsProc = 1&
  strBuffer = Space$(256)
  If SendMessage( _
       hWnd, WM_GETTEXT, Len(strBuffer), strBuffer) Then
    strBuffer _
      = Left$(strBuffer, InStr(strBuffer, Chr$(0)) - 1)
    'Debug.Print strBuffer
    If strBuffer = m_strCaption Then
      'Debug.Print strBuffer
      m_lngHDC = GetDC(hWnd)
      EnumWindowsProc = 0&
    End If
  End If
End Function
Attento perche' con i font Unicode rallenta molto e se ti metti a
pasticciare con mouse o tastiera si blocca tutto. Vedro` che si puo` fare,
quando avro` tempo.


quando avro` tempo.
funziona !!!!!
mi basta anche cosi !
grazie mille


 mi basta anche cosi !
--


tienici informati, grazie.
grazie anche a Mauro che mi scritto, ho partorito questa :
Sub MAIN()
Dim ElencoFont As Object
Dim frase As String
Dim i As Integer
frase = "testo da scrivere"
Set ElencoFont = Application.CommandBars.FindControl(ID:=1728)
 
Range("A:B").ClearContents
For i = 0 To ElencoFont.ListCount - 1
   Cells(i + 1, 1) = ElencoFont.List(i + 1)
   Cells(i + 1, 2).font.Name = ElencoFont.List(i + 1)
   Cells(i + 1, 2) = frase
Next i
End Sub
=============
Allego la nota di Mauro :
Forse è un po' tardi ma c'è un modo ( almeno con Excel 2000 ) ed è
quello di leggere i font direttamente dalla combo di Excel.
Per rintracciare i parametri si può partire dall'oggetto CommandBars :
usando la finestra "Espressioni di controllo" ed espandendo l'oggetto
si trova che l'item 4 ha come proprietà name "Formatting".
Espandendo la proprietà Controls si trova che l'item 1 ha come ID 1728
e la Caption "Tipo di Carattere" quindi è quello che serve.
A questo punto :
     Set Font = Application.CommandBars.FindControl(ID:=1728)
     Range("A:A").ClearContents
     For i = 0 To Font.ListCount - 1
         Cells(i + 1, 1) = Font.List(i + 1)
     Next i
Ho mandato una copia di questo anche a Maurizio Borrelli dato che si
dichiarava interessato ad una soluzione alternativa ma il messaggio mi
è tornato indietro e quindi probabilmente o la casella di posta di
Maurizio è sbagliata o ha qualche problema.
===========


 ===========
Complimenti! Bella soluzione, pulita, immediata e... "naturale". Cosi`
imparo una volta di piu` a metter in pratica quello che "pre`dico" sempre:
prima di metterti a scrivere il codice pensa!
:-))))
Grazie ad entrambi.
