Создание BMP шрифтов
Пример создания BMP шрифтов для функции Draw String. Шрифты создаются на
основе имеющихся шрифтов в системе. Это далеко не конечный вариант, есть что
подделать.
Платформы: Windows.
Автор: jofers, создано 2006 году.
' Файл ресурсов: '#include "windows.h" ' '1000 DIALOGEX 106, 106, 194, 62 'CAPTION "TTF - GfxLib Font Convertor" 'FONT 8, "MS Sans Serif" 'STYLE WS_OVERLAPPED | WS_CAPTION | WS_SYSMENU | WS_MINIMIZEBOX 'EXSTYLE WS_EX_OVERLAPPEDWINDOW 'BEGIN ' CONTROL "Save", 1001, BUTTON, BS_PUSHBUTTON | WS_CHILD | WS_VISIBLE | WS_TABSTOP, 129, 24, 60, 14 ' CONTROL "Select Font", 1002, BUTTON, BS_PUSHBUTTON | WS_CHILD | WS_VISIBLE | WS_TABSTOP, 129, 5, 60, 14 ' CONTROL "Background Color", 1003, BUTTON, BS_PUSHBUTTON | WS_CHILD | WS_VISIBLE | WS_DISABLED | WS_TABSTOP, 109, 43, 80, 14 ' CONTROL "Transparent Background", 1004, BUTTON, BS_AUTOCHECKBOX | WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP, 5, 43, 100, 14 ' CONTROL "AaBbCDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz", 1005, STATIC, SS_LEFT | WS_CHILD | WS_VISIBLE | WS_GROUP, 5, 5, 121, 34 , 0x00020200 ' ' ' 'END #INCLUDE "windows.bi" #INCLUDE "win/commdlg.bi" #INCLUDE "crt.bi" #DEFINE DLG_MAIN 1000 #DEFINE BTN_SAVE 1001 #DEFINE BTN_FONT 1002 #DEFINE BTN_BKGR 1003 #DEFINE CHK_TRAN 1004 #DEFINE LBL_MAIN 1005 #DEFINE ICO_MAIN 1010 Type Global BackgroundColor As COLORREF BitmapInfo As BITMAPINFO ChooseColor As CHOOSECOLOR CustColors(15) As COLORREF ChooseFont As CHOOSEFONT hBrush As HBRUSH hBrushPrev As HBRUSH hFont As HFONT hFontPrev As HFONT IsTransparent As Integer LogFont As LOGFONT OpenFileName As OPENFILENAME SaveName As String*255 SaveFilter As String*255 End Type Declare Function DlgProc (Byval hWnd As HWND, Byval uMsg As UINT, Byval wParam As WPARAM, Byval lParam As LPARAM) As BOOL Declare Sub EditColor(Byval hWnd As HWND) Declare Sub EditFont(Byval hWnd As HWND) Declare Sub SaveFile(Byval hWnd As HWND) Declare Sub SaveBitmap(Byval hWnd As HWND, Byval hDC As HDC, Byval hBitmap As HBITMAP, Byval File As String) Dim Shared Global As Global DialogBox(GetModuleHandle(NULL), MAKEINTRESOURCE(DLG_MAIN), NULL, @DlgProc) End Function DlgProc (Byval hWnd As HWND, Byval uMsg As UINT, Byval wParam As WPARAM, Byval lParam As LPARAM) As BOOL Dim ID As Integer Dim Event As Integer Dim hDC As HDC Dim hBrush As HBRUSH Dim x As Integer Dim SaveFilterArray As Ubyte Ptr Dim hWndControl As HWND Select Case uMsg Case WM_INITDIALOG With Global ' Set up all structure information .SaveFilter = "Bitmap Files (*.bmp)%*.BMP%All Files (*.*)%*.*%%" SaveFilterArray = Strptr(.SaveFilter) For x = 0 To Len(.SaveFilter) If SaveFilterArray[x] = Asc("%") Then SaveFilterArray[x] = 0 Next x .BackgroundColor = GetSysColor(COLOR_WINDOW) .hBrush = GetSysColorBrush(COLOR_WINDOW) .IsTransparent = TRUE memset(@Global.CustColors(0), 255, Sizeof(COLORREF)*16) With .ChooseColor .lStructSize = Sizeof(CHOOSECOLOR) .hWndOwner = hWnd .rgbResult = Global.BackgroundColor .lpCustColors = @Global.CustColors(0) .flags = CC_ANYCOLOR Or CC_RGBINIT Or CC_SOLIDCOLOR End With With .ChooseFont .lStructSize = Sizeof(CHOOSEFONT) .hInstance = GetModuleHandle(NULL) .hWndOwner = hWnd .lpLogFont = @Global.LogFont .Flags = CF_SCREENFONTS Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT End With With .OpenFileName .lStructSize = Sizeof(OPENFILENAME) .hInstance = GetModuleHandle(NULL) .hWndOwner = hWnd .lpstrFilter = Strptr(Global.SaveFilter) .lpstrFile = Strptr(Global.SaveName) .nMaxFile = 255 End With With .LogFont .lfFaceName = "MS Sans Serif" .lfHeight = -MulDiv(8, GetDeviceCaps(GetDC(NULL), LOGPIXELSY), 72) End With Global.hFont = CreateFontIndirect(Global.ChooseFont.lpLogFont) End With CheckDlgButton(hWnd, CHK_TRAN, BST_CHECKED) Global.IsTransparent = TRUE Case WM_CLOSE EndDialog(hWnd, 0) Case WM_CTLCOLORSTATIC If GetDlgCtrlID(Cast(hWND, lParam)) = LBL_MAIN Then hDC = Cast(HDC, wParam) SetTextColor(hDC, Global.ChooseFont.rgbColors) If Global.IsTransParent = TRUE Then SetBkColor(hDC, Rgb(255, 255, 255)) Return Cast(LRESULT, GetSysColorBrush(COLOR_WINDOW)) Else SetBkColor(hDC, Global.BackgroundColor) Return Cast(LRESULT, Global.hBrush) End If End If Case WM_COMMAND ID = Loword(wParam) Event = Hiword(wParam) Select Case ID Case BTN_SAVE SaveFile(hWnd) Case BTN_FONT EditFont(hWnd) Case BTN_BKGR EditColor(hWnd) Case CHK_TRAN hWndControl = GetDlgItem(hWnd, BTN_BKGR) If IsDlgButtonChecked(hWnd, CHK_TRAN) = BST_CHECKED Then Global.IsTransparent = TRUE Global.LogFont.lfQuality = NONANTIALIASED_QUALITY ' Enable the 'background Color' button EnableWindow(hWndControl, FALSE) Else Global.IsTransParent = FALSE Global.LogFont.lfQuality = ANTIALIASED_QUALITY ' Disable the 'background Color' button EnableWindow(hWndControl, TRUE) End If Global.hFontPrev = Global.hFont Global.hFont = CreateFontIndirect(@Global.LogFont) SendDlgItemMessage(hWnd, LBL_MAIN, WM_SETFONT, Cast(WPARAM, Global.hFont), TRUE) DeleteObject(Global.hFontPrev) End Select Case Else Return FALSE End Select Return TRUE End Function Sub EditFont(Byval hWnd As HWND) ' If a font is chosen, set all the variables If ChooseFont(@Global.ChooseFont) = TRUE Then Global.hFontPrev = Global.hFont If Global.IsTransparent = TRUE Then Global.LogFont.lfQuality = NONANTIALIASED_QUALITY Else Global.LogFont.lfQuality = ANTIALIASED_QUALITY End If Global.hFont = CreateFontIndirect(Global.ChooseFont.lpLogFont) SendDlgItemMessage(hWnd, LBL_MAIN, WM_SETFONT, Cast(WPARAM, Global.hFont), TRUE) DeleteObject(Global.hFontPrev) End If End Sub Sub EditColor(Byval hWnd As HWND) Dim hWndControl As HWND If ChooseColor(@Global.ChooseColor) = TRUE Then Global.BackgroundColor = Global.ChooseColor.rgbResult Global.hBrushPrev = Global.hBrush Global.hBrush = CreateSolidBrush(Global.BackgroundColor) DeleteObject(Global.hBrushPrev) hWndControl = GetDlgItem(hWnd, LBL_MAIN) InvalidateRect(hWndControl,NULL,TRUE) UpdateWindow(hWndControl) End If End Sub Sub SaveFile(Byval hWnd As HWND) Dim MemDC As HDC Dim MemBMP As HBITMAP Dim BitmapWidth As Integer Dim BitmapHeight As Integer Dim BitmapSize As Integer Dim BitmapInfo As BITMAPINFO Dim FileName As String Dim i As Integer Dim x As Integer Dim y As Integer Dim WidthArray(32 To 128) As Integer Dim ABCArray(32 To 128) As ABC Dim ThisWidth As SIZE Dim TextMetric As TEXTMETRIC Dim IsTrueType As Integer Dim Buffer As Ubyte Ptr ' If a save name is chosen... If GetSaveFileName(@Global.OpenFileName) Then ' Create a memory DC and select our font into it MemDC = CreateCompatibleDC(NULL) If (MemDC = 0) Or (Global.hFont = 0) Then MessageBox(hWnd, "Could not create Bitmap", "Error", MB_ICONERROR) Exit Sub End If SelectObject(MemDC, Global.hFont) ' Get character widths IsTrueType = GetCharABCWidths(MemDC, 32, 128, @ABCArray(32)) For i = 32 To 128 GetTextExtentPoint32(MemDC, Chr(i), 1, @ThisWidth) If IsTrueType Then WidthArray(i) = ABCArray(i).abcB If ABCArray(i).abcC > 0 Then WidthArray(i) += ABCArray(i).abcC If ABCArray(i).abcA > 0 Then WidthArray(i) += ABCArray(i).abcA Else WidthArray(i) = ThisWidth.cx End If BitmapWidth += WidthArray(i) If ThisWidth.cy > BitmapHeight Then BitmapHeight = ThisWidth.cy Next i BitmapSize = BitmapHeight * BitmapWidth * 4 ' Create DIB section & select it into memory DC With Global.BitmapInfo.bmiHeader .biSize = Sizeof(BITMAPINFOHEADER) .biWidth = BitmapWidth .biHeight = BitmapHeight .biPlanes = 1 .biBitCount = 32 .biCompression = BI_RGB End With MemBMP = CreateDIBSection(MemDC, @Global.BitmapInfo, DIB_RGB_COLORS, @Buffer, NULL, 0) SelectObject MemDC, MemBMP If Global.IsTransparent = True Then SetBkColor(MemDC, Rgb(255, 0, 255)) Else SetBkColor(MemDC, Global.BackgroundColor) End If SetTextColor(MemDC, Global.ChooseFont.rgbColors) If MemBMP = 0 Or Buffer = 0 Then MessageBox(hWnd, "Could not create Bitmap", "Error", MB_ICONERROR) DeleteObject(MemDC) Exit Sub End If ' Fill in font info and draw letters Buffer[BitmapSize-BitmapWidth*4] = 0 Buffer[BitmapSize-BitmapWidth*4+1] = 32 Buffer[BitmapSize-BitmapWidth*4+2] = 128 x = 0 For i = 32 To 128 If ABCArray(i).abcA < 0 Then x -= ABCArray(i).abcA TextOut(MemDC, x, 1, Chr(i), 1) Buffer[BitmapSize-BitmapWidth*4 + i - 29] = WidthArray(i) If ABCArray(i).abcA < 0 Then x += ABCArray(i).abcA x += WidthArray(i) Next i FileName = *Global.OpenFileName.lpstrFile If Ucase(Right(FileName, 4)) <> ".BMP" Then FileName += ".bmp" SaveBitmap(hWnd, MemDC, MemBMP, FileName) MessageBox hWnd, "Complete!", "Hurray!", MB_OK End If End Sub Sub SaveBitmap(Byval hWnd As HWND, Byval hDC As HDC, Byval hBitmap As HBITMAP, Byval File As String) Dim fp As FILE Ptr Dim Bitmap As BITMAP Dim BitmapInfo As BITMAPINFO Dim BitmapFileHeader As BITMAPFILEHEADER Dim Buffer As Ubyte Ptr fp = fopen(File, "wb") If fp = 0 Then MessageBox hWnd, "Error Saving Bitmap", "Error", MB_ICONERROR Exit Sub End If BitmapInfo.bmiHeader.biSize = Sizeof(BITMAPINFOHEADER) BitmapInfo.bmiHeader.biBitCount = 0 If GetDIBits(hDC, hBitmap, 0, 0, NULL, @BitmapInfo, DIB_RGB_COLORS) = 0 Then MessageBox hWnd, "Error Saving Bitmap", "Error", MB_ICONERROR fclose(fp) Exit Sub End If Bitmap.bmHeight = BitmapInfo.bmiHeader.biHeight Bitmap.bmWidth = BitmapInfo.bmiHeader.biWidth With BitmapFileHeader .bfType = &h4d42 .bfSize = (((3 * Bitmap.bmWidth + 3) And Not 3) * Bitmap.bmHeight) .bfSize += Sizeof(BITMAPFILEHEADER) .bfSize += Sizeof(BITMAPINFOHEADER) .bfOffBits = Sizeof(BITMAPFILEHEADER) + Sizeof(BITMAPINFOHEADER) End With BitmapInfo.bmiHeader.biCompression = 0 fwrite(@BitmapFileHeader, Sizeof(BITMAPFILEHEADER),1,fp) fwrite(@BitmapInfo.bmiHeader, Sizeof(BITMAPINFOHEADER),1,fp) Buffer = Allocate(BitmapInfo.bmiHeader.biSizeImage + 5) If GetDIBits(hDC, hBitmap, 0, Bitmap.bmHeight, Buffer, @BitmapInfo, DIB_RGB_COLORS) = 0 Then Deallocate Buffer MessageBox hWnd, "Error Saving Bitmap", "Error", MB_ICONERROR fclose(fp) Exit Sub End If fwrite(Buffer,1,BitmapInfo.bmiHeader.biSizeImage,fp) fclose(fp) End Sub
