文字の回転表示          <TOP>

文字を回転表示させます。
 GetDeviceCaps デバイス固有の情報を取得
BitBlt ビットブロック転送
CreateCompatibleBitmap デバイスコンテキストと互換性のあるビットマップを作成
CreateCompatibleDC 指定されたデバイスコンテキストに関連するデバイスと互換性のあるメモリデバイスコンテキストを作成
CreateEllipticRgn 楕円形のリージョンを作成
SetWindowRgn 指定の領域をウィンドウ領域として設定
CreateFont 指定の属性を持つ論理フォントを作成
SelectObject 指定されたデバイスコンテキストのオブジェクトを選択
TextOut 文字を描画
MulDiv 2つの符号付き32ビット整数を乗算(64ビット)し、その結果を1つの符号付き32ビット整数で除算
SetBkMode バックグラウンドの塗りつぶしモード設定
FillRect ブラシで矩形領域を塗りつぶす
SetRect RECT構造体の値を設定
GetSysColorBrush システムカラーのインデックスに対応した論理ブラシのハンドルを取得
GetDC デバイスコンテキストのハンドルを取得
DeleteDC 指定されたデバイスコンテキストを削除
DeleteObject 論理オブジェクトを削除し、そのオブジェクトに関連付けられていたすべてのシステムリソースを解放
ReleaseDC デバイスコンテキストを解放
　

　

????

統合環境で下記のようにREM[']を入れる位置により

#define FW_NORMAL 400                   '
CreateMyFont = Api_CreateFont(-Api_MulDiv(nSize, Api_GetDeviceCaps(Api_GetDC(0)･････行が文法エラーになります。

私の環境では、

#define FW_NORMAL 400     '半角空白が5個まではOK、6個以上はNGでした。(Windows 7でも同様)

　

'================================================================
'= 文字の回転表示
'=    (MulDiv2.bas)
'================================================================
#include "Windows.bi"

#define FW_BLACK 900                    'LOGFONT(lfWeight)･FW_HEAVY
#define FW_BOLD 700                     'LOGFONT(lfWeight)
#define FW_DEMIBOLD 600                 'LOGFONT(lfWeight)･FW_SEMIBOLD
#define FW_DONTCARE 0                   'LOGFONT(lfWeight)
#define FW_EXTRABOLD 800                'LOGFONT(lfWeight)
#define FW_EXTRALIGHT 200               'LOGFONT(lfWeight)
#define FW_HEAVY 900                    'LOGFONT(lfWeight)
#define FW_LIGHT 300                    'LOGFONT(lfWeight)
#define FW_MEDIUM 500                   'LOGFONT(lfWeight)
#define FW_NORMAL 400
#define FW_REGULAR 400                  'LOGFONT(lfWeight)
#define FW_SEMIBOLD 600                 'LOGFONT(lfWeight)
#define FW_THIN 100                     'LOGFONT(lfWeight)
#define FW_ULTRABOLD 800                'LOGFONT(lfWeight)･FW_EXTRABOLD
#define FW_ULTRALIGHT 200               'LOGFONT(lfWeight)･FW_EXTRALIGHT

#define ANSI_CHARSET 0                  'Windows標準文字セット
#define DEFAULT_CHARSET 1               'デフォルト(指定なし)
#define SYMBOL_CHARSET 2                'シンボル文字セット
#define SHIFTJIS_CHARSET 128            'シフトJIS文字セット
#define HANGEUL_CHARSET 129             'ハングル文字セット
#define CHINESEBIG5_CHARSET 136         '中国語文字セット
#define OEM_CHARSET 255                 'OEM文字セット

#define OUT_CHARACTER_PRECIS 2          '使用されない
#define OUT_DEFAULT_PRECIS 0            'デフォルトの動作に任せる
#define OUT_DEVICE_PRECIS 5             '同じ名前のフォントが複数あった場合、デバイスフォントを選択
#define OUT_OF_MEMORY_OR_RESOURCES 0    'メモリまたはリソースが足りない
#define OUT_OUTLINE_PRECIS 8            'WindowsNT2K･XPではTrueTypeフォントやその他のアウトラインベースのフォントを選択。Windows9xでは使用せ・
#define OUT_RASTER_PRECIS 6             '同じ名前のフォントが複数あった場合、ラスタフォントを選択
#define OUT_STROKE_PRECIS 3             'WindowsNT･2K･XPでは使用しない。Windows9x･Meではベクトルフォントを選択
#define OUT_TT_ONLY_PRECIS 7            'TrueTypeフォントだけを選択。システムにTrueTypeフォントが組み込まれていないときは、デフォルトの動作
#define OUT_TT_PRECIS 4                 '同じ名前のフォントが複数あった場合、TrueTypeフォントを選択

#define CLIP_CHARACTER_PRECIS 1         '使用されない
#define CLIP_DEFAULT_PRECIS 0           'デフォルトの動作に任せる
#define CLIP_STROKE_PRECIS 2            '使用されない
#define DEFAULT_PITCH 0                 '文字ピッチデフォルト
#define DEFAULT_QUALITY 0               'フォントの文字品質は重視されない
#define DRAFT_QUALITY 1                 'フォントの文字品質は、PROOF_QUALITYを使用したときほどは重視されない
#define FIXED_PITCH 1                   '文字ピッチ固定
#define PROOF_QUALITY 2                 'フォントの文字品質が、論理フォントの属性を正確に一致させることよりも重視
#define VARIABLE_PITCH 2                '文字ピッチ可変

#define OPAQUE 2                        '背景色を設定する
#define TRANSPARENT 1                   '背景色を設定しない
#define LOGPIXELSX 88                   'スクリーン幅において１論理インチあたりのピクセル数
#define LOGPIXELSY 90                   'スクリーン高さにおいて１論理インチあたりのピクセル数
#define COLOR_WINDOW 5                  'ウィンドウの背景色
#define SRCCOPY &HCC0020                'そのまま転送
#define MSG "　　札幌市白石区"

Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End Type

' デバイス固有の情報を取得
Declare Function Api_GetDeviceCaps& Lib "gdi32" Alias "GetDeviceCaps" (ByVal hDC&, ByVal nIndex&)

' ビットブロック転送を行う。コピー元からコピー先のデバイスコンテキストへ、指定された長方形内の各ピクセルの色データをコピー
Declare Function Api_BitBlt& Lib "gdi32" Alias "BitBlt" (ByVal hDestDC&, ByVal X&, ByVal Y&, ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC&, ByVal xSrc&, ByVal ySrc&, ByVal dwRop&)

' デバイスコンテキストと互換性のあるビットマップを作成
Declare Function Api_CreateCompatibleBitmap& Lib "gdi32" Alias "CreateCompatibleBitmap" (ByVal hDC&, ByVal nWidth&, ByVal nHeight&)

' 指定されたデバイスコンテキストに関連するデバイスと互換性のあるメモリデバイスコンテキストを作成
Declare Function Api_CreateCompatibleDC& Lib "gdi32" Alias "CreateCompatibleDC" (ByVal hDC&)

' 楕円形のリージョンを作成
Declare Function Api_CreateEllipticRgn& Lib "gdi32" Alias "CreateEllipticRgn" (ByVal nLeftRect&, ByVal nTopRect&, ByVal nRightRect&, ByVal nBottomRect&)

' 指定の領域をウィンドウ領域として設定
Declare Function Api_SetWindowRgn& Lib "user32" Alias "SetWindowRgn" (ByVal hWnd&, ByVal hRgn&, ByVal bRedraw&)

' 指定の属性を持つ論理フォントを作成
Declare Function Api_CreateFont& Lib "gdi32" Alias "CreateFontA" (ByVal Hei&, ByVal Wid&, ByVal Esc&, ByVal Ori&, ByVal Wei&, ByVal Ita&, ByVal Und&, ByVal Stk&, ByVal Chr&, ByVal Out&, ByVal Clp&, ByVal Qua&, ByVal Pit&, ByVal Face$)

' 指定されたデバイスコンテキストのオブジェクトを選択
Declare Function Api_SelectObject& Lib "gdi32" Alias "SelectObject" (ByVal hDC&, ByVal hObject&)

' 文字を描画
Declare Function Api_TextOut& Lib "gdi32" Alias "TextOutA" (ByVal hDC&, ByVal nXStart&, ByVal nYStart&, ByVal lpString$, ByVal cbString&)

' 2つの符号付き32ビット整数を乗算(64ビット)し、その結果を1つの符号付き32ビット整数で除算
Declare Function Api_MulDiv& Lib "Kernel32" Alias "MulDiv" (ByVal nNumber&, ByVal nNumerator&, ByVal nDenominator&)

' バックグラウンドの塗りつぶしモード設定
Declare Function Api_SetBkMode& Lib "gdi32" Alias "SetBkMode" (ByVal hDC&, ByVal iBkMode&)

' ブラシで矩形領域を塗りつぶす
Declare Function Api_FillRect& Lib "user32" Alias "FillRect" (ByVal hDC&, ByRef r As RECT, ByVal hBrush&)

' RECT構造体の値を設定
Declare Function Api_SetRect& Lib "user32" Alias "SetRect" (lpRect As RECT, ByVal X1&, ByVal Y1&, ByVal X2&, ByVal Y2&)

' システムカラーのインデックスに対応した論理ブラシのハンドルを取得
Declare Function Api_GetSysColorBrush& Lib "user32" Alias "GetSysColorBrush" (ByVal nIndex&)

' 指定されたウィンドウのクライアント領域または画面全体を表すディスプレイデバイスコンテキストのハンドルを取得
Declare Function Api_GetDC& Lib "user32" Alias "GetDC" (ByVal hWnd&)

' 指定されたデバイスコンテキストを削除
Declare Function Api_DeleteDC& Lib "gdi32" Alias "DeleteDC" (ByVal hDC&)

' 論理オブジェクトを削除し、そのオブジェクトに関連付けられていたすべてのシステムリソースを解放
Declare Function Api_DeleteObject& Lib "gdi32" Alias "DeleteObject" (ByVal hObject&)

' デバイスコンテキストを解放
Declare Function Api_ReleaseDC& Lib "user32" Alias "ReleaseDC" (ByVal hWnd&, ByVal hDC&)

Var Shared hDC As Long
Var Shared mDC As Long
Var Shared mBitmap As Long

'================================================================
'=
'================================================================
Declare Function CreateMyFont(nSize As Integer, nDegrees As Long) As Long
Function CreateMyFont(nSize As Integer, nDegrees As Long) As Long
    CreateMyFont = Api_CreateFont(-Api_MulDiv(nSize, Api_GetDeviceCaps(Api_GetDC(0), LOGPIXELSY), 72), 0, nDegrees * 10, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, "ＭＳ ゴシック")
End Function

'================================================================
'=
'================================================================
Declare Sub MainForm_Start edecl ()
Sub MainForm_Start()
    Var mRGN As Long
    Var Cnt As Long
    Var mBrush As Long
    Var R As RECT
    Var Ret As Long
    
    hDC = Api_GetDC(GethWnd)
    mDC = Api_CreateCompatibleDC(Api_GetDC(0))
    mBitmap = Api_CreateCompatibleBitmap(Api_GetDC(0), GetWidth, GetHeight)
        
    Ret = Api_SelectObject(mDC, mBitmap)
    Ret = Api_SetBkMode(mDC, TRANSPARENT)
    Ret = Api_SetRect(R, 0, 0, GetWidth, GetHeight)
    Ret = Api_FillRect(mDC, R, Api_GetSysColorBrush(COLOR_WINDOW))

    For Cnt = 0 To 330 Step 30
        Ret = Api_DeleteObject(Api_SelectObject(mDC, CreateMyFont(14, Cnt)))
        Ret = Api_TextOut(mDC, GetWidth / 2, GetHeight / 2　-　18, MSG, Len(MSG))
    Next Cnt

    mRGN = Api_CreateEllipticRgn(0, 0, GetWidth, GetHeight)
    Ret = Api_SetWindowRgn(GethWnd, mRGN, True)

    Ret = Api_DeleteObject(mRGN)
End Sub

'================================================================
'=
'================================================================
Declare Sub MainForm_MouseMove edecl ()
Sub MainForm_MouseMove()
    Var Ret As Long

    Ret = Api_BitBlt(hDC, 0, 0, GetWidth, GetHeight, mDC, 0, 0, SRCCOPY)
End Sub

'================================================================
'=
'================================================================
Declare Sub MainForm_Click edecl ()
Sub MainForm_Click()
    Var Ret As Long

    Ret = Api_ReleaseDC(GethWnd, hDC)
    Ret = Api_DeleteDC(mDC)
    Ret = Api_DeleteObject(mBitmap)
    End
End Sub

'================================================================
'=
'================================================================
While 1
    WaitEvent
Wend
Stop
End