/**** The following program contains two macros, %GENFONTS and %FONTLNKS. The %GENFONTS macro imports font information from .AFM files that you specify in the SAS registry. The %FONTLNKS macro adds links to these fonts in the Universal Printers that you designate. ****/ %macro genfonts(afmdir,afmfiles,outdir,replace); /* This genfonts utility will read a list of .AFM files to process and then: - Generate a .sasxreg file appropriate for importing the new font information to the SAS Registry. - Import the .sasxreg file to the SAS Registry. - Generate a fontlnks.txt file that may be used later by the fontlnks macro utility. This will create font links in the desired SAS Universal printer(s) and/or prototype(s) which will allow them to access the new font(s). afmdir => Directory where .AFM file resides afmfiles => Name of file containing all .AFM file names (with extension) to process. Specify one name per record and begin in column 1 of each. Make sure no carriage control, tabs, etc exist on the record following the last name in the file. This could be falsely interpreted as a file name. It is assumed this file is in the afmdir directory. outdir => Directory where generated .sasxreg and working files will reside replace => Indicates whether or not to add a font entry in the SAS Registry if the font, in one of the .AFM files being processed, already exists in the SAS Registry. Valid values are: No => Do not generate info for the font in the .sasxreg file if the font already exists in SAS Registry. Yes => Generate the font info even if the font already exists. In both of the above cases, a Warning message will be issued to the SAS Log. */ filename final "&outdir\final.sasxreg"; /* The final result */ filename header "&outdir\header.txt"; /* Header section of family */ filename charsets "&outdir\charsets.txt"; /* CHARACTER SETS key section */ filename weights "&outdir\weights.txt"; /* WEIGHTS key section */ filename styles "&outdir\styles.txt"; /* STYLES key section */ filename codes "&outdir\codes.txt"; /* CODE key section */ filename ftlinks "&outdir\fontlnks.txt"; /* Links that may be used to point to the new fonts in the SAS Registry. */ filename temp1 "&outdir\temp1.txt"; /* Temporary file */ filename temp2 "&outdir\temp2.txt"; /* Temporary file */ /* Generate list of PostScript hardware fonts already supported by the SAS Registry. */ proc printto log=temp1 new; run; /* Generate master list of supported PostScript hardware Fonts from SAS Registry. Note this does not include user-added fonts which reside off of the HKEY_USER_ROOT location instead of HKEY_SYSTEM_ROOT. */ proc registry list startat='HKEY_SYSTEM_ROOT\Core\Printing\PSL\Fonts'; run; proc printto; /* Reset Log dest back to default */ run; /* Parse font information to only lines that begin with [ or Font=. This will reduce the amount of info the following work.sasfnts data step will have to process. */ data _null_; retain flag 0; length record $250; file temp2 lrecl=250 pad; infile temp1 lrecl=250 pad; input record $char250.; record = left(record); /* Move leading blanks, if they exist, to end of record */ /* First occurance with bracket is the key name. We do not need this. */ if record=:'[' and flag=0 then do; flag=1; return; end; else if record=:'[' then put record; else if record=:'Font=' then put record; run; /* Generate SAS data set containing SAS name for PostScript hardware font family (contained in SASFAM variable), the actual PostScript hardware font name - required to select the font on the printer (contained in FONTNAME variable), and the code associated with the font in the SAS Registry (contained in CODE variable). */ data work.sasfnts(keep=sasfam fontname code); retain flag 0 codeflg 0 sasfam; length record $250 sasfam fontname $50 code $9; infile temp2 lrecl=250 pad end=eof; /* The first SAS hardware font family name is on the first record. After that, it is always followed by the record containing WEIGHTS. */ if _n_=1 then do; input record $char250.; /* Grab value between the square brackets in the string */ sasfam = left(scan(substr(record, index(record, '[')+1),1,']')); flag = 0; codeflg = 0; do until(flag); input record $char250.; if codeflg=0 AND left( scan(substr(record, index(record, '[')+1),1,']') ) = 'CODE' then do; input record $char250.; /* The record following CODE is code for 1st font */ code = left( scan(substr(record, index(record, '[')+1),1,']') ); /* The code for each font preceeds the font name on the previous line */ input record $char250.; /* Get font name */ fontname = scan(substr(record, index(record, '"')+1),1,'"'); codeflg = 1; /* Indicate code for first font in first family was found */ output; end; else if left( scan(substr(record, index(record, '[')+1),1,']') ) = 'STYLES' then do; /* Note: STYLES is the record just prior to WEIGHTS */ flag=1; /* Indicate all fonts in first family have been found */ end; else if codeflg =1 then do; /* First font has already been processed */ code = left( scan(substr(record, index(record, '[')+1),1,']') ); input record $char250.; /* Get font name */ fontname = scan(substr(record, index(record, '"')+1),1,'"'); output; end; end; end; /* The record after WEIGHTS will contain the next SAS hardware font family name. However, WEIGHTS will also be on the last record after the last font info is read. */ input record $char250.; if left( scan(substr(record, index(record, '[')+1),1,']') ) = 'WEIGHTS'; if eof then stop; /* WEIGHTS will be on the last record in the input file after the last font info is read. If so, stop processing. */ input record $char250.; sasfam = left(scan(substr(record, index(record, '[')+1),1,']')); flag = 0; codeflg = 0; do until(flag); input record $char250.; if codeflg=0 AND left( scan(substr(record, index(record, '[')+1),1,']') ) = 'CODE' then do; input record $char250.; /* Get code for 1st font of this font family */ code = left( scan(substr(record, index(record, '[')+1),1,']') ); input record $char250.; /* Get font name */ fontname = scan(substr(record, index(record, '"')+1),1,'"'); codeflg = 1; /* Indicate code for first font in first family was found */ output; end; else if left( scan(substr(record, index(record, '[')+1),1,']') ) = 'STYLES' then do; /* Note: STYLES is the record just prior to WEIGHTS */ flag=1; /* Indicate all fonts in this family have been found */ end; else if codeflg =1 then do; /* First font has already been processed */ code = left( scan(substr(record, index(record, '[')+1),1,']') ); input record $char250.; /* Get font name */ fontname = scan(substr(record, index(record, '"')+1),1,'"'); output; end; end; run; /* A hardware font name will occur multiple times if different character sets are associated with it. For example, a font will occur twice if Western/ISOLatin1 and English-USA character sets are available. */ proc sort data=work.sasfnts; by fontname code; run; /**** REMOVED PROC PRINT ***/ /* Generate .sasxreg files */ data work.afmlist; infile "&afmdir\&afmfiles" lrecl=250 pad; input filenams $50.; /* Max length of .AFM filename plus extension is 50 */ run; data work.font(drop=temp record); retain; /* Retain all variables */ length record $250 family fontname fullname width $50 weight $12 temp $30 spacing stylec widthc $1 familyc weightc $2 encoding $6 style $7 fileloc $100 encodec $20 code $9; set work.afmlist; /* Input list of .AFM files to scan */ fileloc = "&afmdir"||'\'||filenams; infile temp1 filevar=fileloc lrecl=250 pad end=eof; do until(eof); /* Read all records of .AFM file to gather information */ input record $char250.; if record=:'FontName ' then do; fontname = trim(left(substr(record, index(record,' ')+1))); if index(upcase(fontname),'ITALIC') OR index(upcase(fontname),'KURSIV') then do; style = 'Italic'; stylec = '2'; /* code for Italic */ end; /* If font name contains Oblique or last 3 letters of font name are Obl, then font is Oblique. */ else if index(upcase(fontname),'OBLIQUE') OR reverse(substr(left(reverse(upcase(fontname))),1,3))='OBL' then do; style = 'Oblique'; stylec = '3'; /* code for Oblique */ end; else do; style = 'Regular'; /* default */ stylec = '1'; /* code for Regular */ end; end; else if record=:'FamilyName ' then do; family = trim(left(substr(record, index(record,' ')+1))); if index(upcase(compress(family)),'TIMESROMAN') then familyc = '1'; else if index(upcase(family),'COURIER') then familyc = '3'; else if index(upcase(family),'SYMBOL') then familyc = '4'; else if index(upcase(compress(family)),'ITCAVANTGARDEGOTHIC') then familyc = '5'; else if index(upcase(compress(family)),'ITCBOOKMAN') then familyc = '6'; else if index(upcase(compress(family)),'NEWCENTURYSCHOOLBOOK') then familyc = '7'; else if index(upcase(family),'PALATINO') then familyc = '8'; else if index(upcase(compress(family)),'ITCZAPFCHANCERY') then familyc = '9'; else if index(upcase(compress(family)),'ITCZAPFDINGBATS') then familyc = '10'; else familyc = '2'; /* Helvetica (default) */ end; else if record=:'FullName ' then do; fullname = trim(left(substr(record, index(record,' ')+1))); if index(upcase(fullname),'NARROW') then do; widthc = '1'; width = 'Narrow'; end; else if index(upcase(fullname),'WIDE') then do; widthc = '3'; width = 'Wide'; end; else if index(upcase(compress(fullname)),'DOUBLEWIDE') then do; widthc = '4'; width = 'Double Wide'; end; else if index(upcase(fullname),'CONDENSED') then do; widthc = '5'; width = 'Condensed'; end; else if index(upcase(compress(fullname)),'EXTRACOMPRESSED') then do; widthc = '7'; width = 'Extra Compressed'; end; else if index(upcase(compress(fullname)),'ULTRACOMPRESSED') OR index(upcase(compress(fullname)),'ULTRACONDENSED') then do; widthc = '8'; width = 'Ultra Compressed'; end; else if index(upcase(fullname),'COMPRESSED') then do; widthc = '6'; width = 'Compressed'; end; else if index(upcase(fullname),'EXPANDED') then do; widthc = '9'; width = 'Expanded'; end; else do; widthc = '2'; /* Normal width (default) */ width = 'Normal'; end; end; else if record=:'Weight ' then do; weight = trim(left(substr(record, index(record,' ')+1))); /* Convert some Weight names to ones that can be used by SAS */ if upcase(weight) IN ('REGULAR', 'ROMAN') then weight = 'Normal'; else if upcase(weight) IN ('COMPACT', 'POSTER') then weight = 'ExtraBlack'; select; when (index(upcase(compress(weight)),'THIN')) do; weight = 'Thin'; weightc = '01'; end; when (index(upcase(compress(weight)),'EXTRALIGHT')) do; weight = 'ExtraLight'; weightc = '02'; end; when (index(upcase(compress(weight)),'LIGHT')) do; weight = 'Light'; weightc = '03'; end; when (index(upcase(compress(weight)),'BOOK')) do; weight = 'Book'; weightc = '05'; end; when (index(upcase(compress(weight)),'MEDIUM')) do; weight = 'Medium'; weightc = '06'; end; when (index(upcase(compress(weight)),'SEMIBOLD')) do; weight = 'Semibold'; weightc = '07'; end; when (index(upcase(compress(weight)),'DEMI')) do; weight = 'Demi'; weightc = '08'; end; when (index(upcase(compress(weight)),'BOLD')) do; weight = 'Bold'; weightc = '09'; end; when (index(upcase(compress(weight)),'HEAVY')) do; weight = 'Heavy'; weightc = '10'; end; when (index(upcase(compress(weight)),'EXTRABOLD')) do; weight = 'ExtraBold'; weightc = '11'; end; when (index(upcase(compress(weight)),'ULTRA')) do; weight = 'UltraBold'; weightc = '12'; end; when (index(upcase(compress(weight)),'BLACK')) do; weight = 'Black'; weightc = '13'; end; when (index(upcase(compress(weight)),'EXTRABLACK')) do; weight = 'ExtraBlack'; weightc = '14'; end; otherwise do; weight = 'Normal'; weightc = '04'; /* Normal weight (default) */ end; end; end; else if record=:'IsFixedPitch ' then do; temp = upcase(trim(left(substr(record, index(record,' ')+1)))); if temp = 'FALSE' then spacing='8'; /* Proportional */ else if temp = 'TRUE' then spacing='4'; /* Uniform */ end; else if record=:'EncodingScheme ' then do; temp = upcase(compress(trim(left(substr(record, index(record,' ')+1))))); if index(temp,'FONTSPECIFIC') then do; encoding = '000003'; /* Font Specific */ encodec = 'Font Specific'; end; else if index(temp,'ADOBESTANDARDENCODING') then do; encoding = '000043'; /* Adobe Standard Encoding - English-USA */ encodec = 'English-USA'; end; /* .AFM files containing the following encodings (except for the Default value of ISOLatin1) have not been tested. If you require any of these encoding types, please look at the EncodingScheme field in your .AFM file to determine the correct encoding value/string. Replace the encoding string to search for in the appropriate INDEX function below (note: the strings used below must be uppercase with all spaces removed). */ else if index(temp,'ANSI-7BIT') then do; encoding = '000005'; /* ANSI 7 - bit */ encodec = 'ANSI - 7 bit'; end; else if index(temp,'FRENCHGERMANSWISS') then do; encoding = '000006'; /* French/German/Swiss */ encodec = 'French/German/Swiss'; end; else if index(temp,'GREEK') then do; encoding = '000009'; /* Greek */ encodec = 'Greek'; end; else if index(temp,'CYRILLIC') then do; encoding = '000010'; /* Cyrillic */ encodec = 'Cyrillic'; end; else if index(temp,'KATAKANA') then do; encoding = '000014'; /* Katakana */ encodec = 'Katakana'; end; else if index(temp,'FINNISHSWEDISH') then do; encoding = '000016'; /* Finnish/Swedish */ encodec = 'Finnish/Swedish'; end; else if index(temp,'DANISHNORWEGIAN') then do; encoding = '000018'; /* Danish/Norwegian */ encodec = 'Danish/Norwegian'; end; else if index(temp,'GERMAN') then do; encoding = '000020'; /* German */ encodec = 'German'; end; else if index(temp,'FRENCH') then do; encoding = '000021'; /* French */ encodec = 'French'; end; else if index(temp,'ENGLISH-UK') then do; encoding = '000022'; /* English-UK */ encodec = 'English-UK'; end; else if index(temp,'ITALIAN') then do; encoding = '000023'; /* Italian */ encodec = 'Italian'; end; else if index(temp,'SPANISH') then do; encoding = '000025'; /* Spanish */ encodec = 'Spanish'; end; else if index(temp,'JIS12-88-CFENCODING') then do; encoding = '000028'; /* Japanese */ encodec = 'Japanese'; end; else if index(temp,'KOREAN') then do; encoding = '000029'; /* Korean */ encodec = 'Korean'; end; else if index(temp,'TRADITIONALCHINESE') then do; encoding = '000031'; /* Traditional Chinese */ encodec = 'Traditional Chinese'; end; else if index(temp,'SIMPLIFIEDCHINESE') then do; encoding = '000032'; /* Simplified Chinese */ encodec = 'Simplified Chinese'; end; else if index(temp,'TURKISH') then do; encoding = '000033'; /* Turkish */ encodec = 'Turkish'; end; else if index(temp,'HEBREW') then do; encoding = '000034'; /* Hebrew */ encodec = 'Hebrew'; end; else if index(temp,'ARABIC') then do; encoding = '000035'; /* Arabic */ encodec = 'Arabic'; end; else if index(temp,'BALTIC') then do; encoding = '000036'; /* Baltic */ encodec = 'Baltic'; end; else if index(temp,'THAI') then do; encoding = '000037'; /* Thai */ encodec = 'Thai'; end; else if index(temp,'CENTRALEUROPEAN') then do; encoding = '000038'; /* Central European - ISOLatin2 */ encodec = 'Central European'; end; else if index(temp,'VIETNAMESE') then do; encoding = '000039'; /* Vietnamese */ encodec = 'Vietnamese'; end; else if index(temp,'ESTONIAN') then do; encoding = '000041'; /* Estonian */ encodec = 'Estonian'; end; else if index(temp,'UNICODE') then do; encoding = '000042'; /* Unicode */ encodec = 'Unicode'; end; else if index(temp,'UTF-8') then do; encoding = '000044'; /* UTF-8 */ encodec = 'UTF-8'; end; /* Default */ else do; encoding = '000001'; /* (Default) ISOLatin1Encoding - Western */ encodec = 'Western/ISOLatin1'; end; end; end; /* End of Do-Until */ code = stylec||trim(left(weightc))||encoding; /* Create code to use in CODE key */ /* If the font width is anything other than Normal, add the width value to the font family name. This is because a font family can be available in different widths. For example, ITC Avant Garde Gothic and ITC Avant Garde Gothic Condensed. In this case, the required width value in the font header information in the .sasxreg file would need to be different. Therefore, two separate font families need to be created. */ if width NE 'Normal' then family = trim(family)||' '||width; /* If the full name of the font contains both Small Caps and Old Style, add this to the family name. */ if index(upcase(compress(fullname)),'SMALLCAPS') AND index(upcase(compress(fullname)),'OLDSTYLE') then family = trim(family)||' Small Caps Old Style'; /* If last 3 letters of font name are OsF, font is Old Style */ else if reverse(substr(left(reverse(upcase(fontname))),1,3))='OSF' then family = trim(family)||' Old Style'; /* If last 3 letters of font name are SC, font is Small Caps */ else if reverse(substr(left(reverse(upcase(fontname))),1,2))='SC' then family = trim(family)||' Small Caps'; run; proc sort data=work.font; by fontname code; run; /* Determine if the font being processed already exists in the SAS Registry. Note that it is possible for the same font name to exist more than once if different encodings are being used (e.g. English-USA and Western/ISOLatin1). That is why the CODE variable is also being used with the merge. */ %if %upcase(&replace) = YES %then %do; data _null_; length record $250; merge work.sasfnts(in=a) work.font(in=b); by fontname code; if a AND b then do; /* Font already exists in SAS Registry */ record = 'WARNING: The '||trim(fontname)||' font with '||trim(encodec)||' encoding is already'; put record; record = 'WARNING: available in the '||trim(sasfam)||' font family in the SAS Registry.'; put record; record = 'WARNING: Information for this font will be added to the SAS Registry again'; put record; record = 'WARNING: in the '||trim(family)||' family.'; put record; put; /* Add blank line */ end; run; %end; %else %if %upcase(&replace) = NO %then %do; data work.font(drop=sasfam); length record $250; merge work.sasfnts(in=a) work.font(in=b); by fontname code; if a AND b then do; /* Font already exists in SAS Registry */ record = 'WARNING: The '||trim(fontname)||' font with '||trim(encodec)||' encoding is already'; put record; record = 'WARNING: available in the '||trim(sasfam)||' font family in the SAS Registry.'; put record; record = 'WARNING: It will not be added to the SAS Registry again.'; put record; put; /* Add blank line */ delete; /* Remove this observation from work.font data set */ end; if b; /* Only keep observations from work.font data set */ run; %end; proc sort data=work.font; by family; run; /* Process each font family individually */ data work.font; retain bygroup; set work.font end=eof; by family; if _n_=1 then bygroup=0; /* Create a numeric identifier for each Font family */ if first.family then bygroup+1; if eof then call symput('maxfam',bygroup); /* Maxfam macro var will contain number of families */ run; %do i=1 %to &maxfam; /* Create subset of each individual Font family */ data work.temp; set work.font(where=(bygroup=&i)); run; /* HEADER */ data _null_; file header lrecl=250; /* Overwrite existing file, if it exists */ length record $250; set work.temp; if _n_=1 then do; /* If v9 or greater, ATTRIBUTES must be in font key */ if floor(&sysver) = 8 then record = '[CORE\PRINTING\PSL\FONTS\'||trim(family)||']'; else if floor(&sysver) > 8 then record = '[CORE\PRINTING\PSL\FONTS\'||trim(family)||'\ATTRIBUTES]'; put record; record = '"Family" = int:'||trim(familyc); put record; record = '"Width" = int:'||widthc; put record; record = '"Spacing" = int:'||spacing; put record; record = '"Scale" = int:1'; put record; record = '"Type" = int:1'; put record; record = '"Sizes" = "8,9,10,11,(12,73,2)"'; put record; put; /* Add blank line */ end; run; /* CHARSETS */ proc sort data=work.temp out=work.temp2 nodupkey; by encoding; /* Remove duplicates of encoding values */ run; data _null_; file charsets lrecl=250; /* Overwrite existing file, if it exists */ length record $250; set work.temp2 end=eof; if _n_=1 then do; record = '[CORE\PRINTING\PSL\FONTS\'||trim(family)||'\CHARACTER SETS]'; put record; end; select (encoding); when ('000001') /* ISOLatin1 */ record = '"Western" = link:"\\CORE\\PRINTING\\PSL\\CHARACTER SETS\\Western"'; when ('000003') record = '"Font Specific" = link:"\\CORE\\PRINTING\\PSL\\CHARACTER SETS\\Font Specific"'; when ('000028') record = '"ShiftJIS" = link:"\\CORE\\PRINTING\\PSL\\CHARACTER SETS\\ShiftJIS"'; otherwise /* '000043' */ record = '"English-USA" = link:"\\CORE\\PRINTING\\PSL\\CHARACTER SETS\\English-USA"'; end; put record; if eof then put; /* Add blank line */ run; /* WEIGHTS */ proc sort data=work.temp out=work.temp2 nodupkey; by weightc; /* Remove duplicates of weight values */ run; data _null_; file weights lrecl=250; /* Overwrite existing file, if it exists */ length record $250; set work.temp2 end=eof; if _n_=1 then do; record = '[CORE\PRINTING\PSL\FONTS\'||trim(family)||'\WEIGHTS]'; put record; end; record = '"'||trim(weight)||'" = int:'||left(put(input(weightc,2.),2.)); /* truncate leading 0 */ put record; if eof then put; /* Add blank line */ run; /* STYLES */ proc sort data=work.temp out=work.temp2 nodupkey; by stylec; /* Remove duplicates of style values */ run; data _null_; file styles lrecl=250; /* Overwrite existing file, if it exists */ length record $250; set work.temp2 end=eof; if _n_=1 then do; record = '[CORE\PRINTING\PSL\FONTS\'||trim(family)||'\STYLES]'; put record; end; record = '"'||trim(style)||'" = int:'||stylec; put record; if eof then put; /* Add blank line */ run; /* CODES */ proc sort data=work.temp out=work.temp2; by code; /* There should be no duplicates of the codes to remove */ run; data _null_; file codes lrecl=250; /* Overwrite existing file, if it exists */ length record $250; set work.temp2; record = '[CORE\PRINTING\PSL\FONTS\'||trim(family)||'\CODE\'||code||']'; put record; record = '"Font" = "'||trim(fontname)||'"'; put record; /* Assume .AFM file processed with Proc Genfmd had .AFM extension */ record = '"Metrics" = "AFM_'||trim(left(upcase(substr(filenams,1,index(filenams,'.')-1))))||'"'; put record; put; /* Add blank line */ run; filename family&i "&outdir\family&i..sasxreg"; /* The final result per font family */ /* Build one .sasxreg file per Font family */ data _null_; length name $ 250; if _n_=1 then name="&outdir/header.txt"; else if _n_= 2 then name="&outdir/charsets.txt"; else if _n_= 3 then name="&outdir/weights.txt"; else if _n_= 4 then name="&outdir/styles.txt"; else if _n_= 5 then name="&outdir/codes.txt"; infile dummy filevar=name end=end; do until (end); input; file family&i lrecl=250; /* Append above files to create the .sasxreg file */ put _infile_; end; run; %end; /* Build a list of Links that point to the new fonts in the SAS Registry. These links must later be associated with a Universal Printer driver or Prototype before it can access the new fonts. Use the fontlnks utility to later process this file. */ proc sort data=work.font out=work.temp2 nodupkey; by family; run; data _null; file ftlinks lrecl=250; /* Overwrite existing file, if it exists */ length record $ 250; set work.temp2; record = '"'||trim(family)||'" = link:"\\CORE\\PRINTING\\PSL\\FONTS\\'||trim(family)||'"'; put record; run; /* Build the final .sasxreg file that includes all Font families processed */ data _null_; length name $ 250; %do i=1 %to &maxfam; %if &i = 1 %then %do; if _n_= 1 then name="&outdir/family1.sasxreg"; %end; %else %do; else if _n_= &i then name="&outdir/family&i..sasxreg"; %end; %end; infile dummy filevar=name end=end; do until (end); input; file final lrecl=250; /* Combine all the above files together into final file */ put _infile_; end; run; /* Create font metric entries in the SASUSER.COREPRN catalog so that they may be used with SAS. NOTE: This will process *all* .AFM files located in the afmdir directory location that was passed into this macro application. */ proc genfmd path="&afmdir" cat=coreprn lib=sasuser type=psl; run; /* Add all the new font information to the SAS Registry */ proc registry import="&outdir\final.sasxreg"; run; %mend genfonts; /**** Begin code for FONTLNKS macro ****/ %macro fontlnks(indir,fntlinks,protnams,outdir); /* This fontlnks utility will add links to the SAS Registry that point to the new PostScript hardware fonts previously added using the genfonts utility. A link for each font must be added to a SAS Universal Printer and/or Prototype before that printer or prototype can access the font. indir => Directory where the following fntlinks file resides. fntlinks => Name of file containing all the links to the new PostScript fonts that were added to the SAS Registry. It is assumed this file is in the indir directory. Note: This is the file generated by the genfonts macro utility. protnams => Name of file (with extension) containing all SAS Universal Printer prototypes and/or Printer names to process. Specify one name per record and begin in column 1 of each. Make sure no carriage control, tabs, etc exist on the record following the last name in the file. This could be falsely interpreted as a name. It is assumed this file is in the indir directory. outdir => Directory where generated .sasxreg and temp files will reside. */ filename final "&outdir\final2.sasxreg"; /* The final result */ filename temp1 "&outdir\temp1.txt"; /* Temporary file */ filename temp2 "&outdir\temp2.txt"; /* Temporary file */ /* Generate list of Universal Printer prototype names contained in the SAS Registry. */ proc printto log=temp1 new; run; /* Generate master list of Prototypes and their values */ proc registry list startat='HKEY_SYSTEM_ROOT\Core\Printing\Prototypes'; run; proc printto; /* Reset Log dest back to default */ run; /* Subset the above file and keep only records beginning with '[' */ data _null_; retain flag 0; length record $250; file temp2 lrecl=250 pad; infile temp1 lrecl=250 pad; input record $char250.; record = left(record); /* Move leading blanks, if they exist, to end of record */ /* First occurance with bracket is the key name. We do not need this. */ if record=:'[' and flag=0 then do; flag=1; return; end; else if record=:'[' then put record; run; /* Generate list of SAS Prototype names */ data work.sasprots(keep=protname); length record $250 protname $50; infile temp2 lrecl=250 pad; input record $char250.; if substr(record,2,1) = ' ' AND substr(record,6,1) NE ' '; protname = trim(left(compress(record,'[]'))); /* Strip brackets and leading spaces */ run; proc sort data=work.sasprots; by protname; run; /* proc print data=work.sasprots; title 'work.sasprots'; run; */ /* Generate SAS data set containing prototypes and/or printer names to process */ data work.userlist; infile "&indir\&protnams" lrecl=250 pad; input protname $50.; /* Max length of Prototype or Printer name */ run; proc sort data=work.userlist; by protname; run; /**** REMOVED PROC PRINT ***/ /* Generate SAS data set containing links to the new fonts added to SAS Registry. This reads the file previously generated by the genfonts macro utility. */ data work.userlnks; infile "&indir\&fntlinks" lrecl=250 pad; input links $250.; run; proc sort data=work.userlnks; by links; run; /**** REMOVED PROC PRINT ***/ /* Generate final2.sasxreg file that contains prototype and/or printer keys with all font links for each key. */ data _null_; file final lrecl=250; /* Overwrite existing file, if it exists */ length record $250; merge work.sasprots(in=a) work.userlist(in=b); by protname; eof=0; /* Reset eof flag */ if a AND b then do; /* Name is a prototype */ record = '[CORE\PRINTING\PROTOTYPES\'||trim(protname)||'\PRINTER SETUP\FONTS]'; put record; do until(eof); set work.userlnks end=eof; put links; if eof then put; /* Add blank line */ end; end; else if b then do; /* Name is not a prototype. It is a printer. */ record = '[CORE\PRINTING\PRINTERS\'||trim(protname)||'\PRINTER SETUP\FONTS]'; put record; do until(eof); set work.userlnks end=eof; put links; if eof then put; /* Add blank line */ end; end; run; /* Add the above information to the SAS Registry */ /**** WE NEED THIS PROC REGISTRY STATEMENT UNCOMMENTED ****/ proc registry import="&outdir\final2.sasxreg"; run; %mend fontlnks; /**** Invoke the GENFONTS macro ****/ /** AFMDIR: Directory where AFM files are stored FONTLIST.TXT: Text file containing the names of the AFM files to import. You must create this file before executing the macro. You can use a different filename if desired. OUTDIR: Directory used to write out files from the macro **/ %genfonts(AFMDIR,FONTLIST.TXT,OUTDIR,Yes) /**** Invoke the FONTLNKS macro ****/ /** INDIR: Directory where the FONTLNKS.TXT file resides FONTLNKS.TXT: Text file containing registry link values for the fonts. Generated by GENFONTS macro. PROTNAMS.TXT: Text file containing the Universal printers or prototypes you wish to modify. You create this file before executing the macro. You can use a different filename if desired. OUTDIR: Directory used to write out files from the macro **/ %fontlnks(INDIR,FONTLNKS.TXT,PROTNAMS.TXT,OUTDIR)