frog.raindrop.jp.knowledge

Option Explicit

''
'' GetDCEx
''
Private Const DCX_CACHE             As Long = &H2&
Private Const DCX_CLIPCHILDREN      As Long = &H8&
Private Const DCX_CLIPSIBLINGS      As Long = &H10&
Private Const DCX_EXCLUDERGN        As Long = &H40&
Private Const DCX_EXCLUDEUPDATE     As Long = &H100&
Private Const DCX_INTERSECTRGN      As Long = &H80&
Private Const DCX_INTERSECTUPDATE   As Long = &H200&
Private Const DCX_LOCKWINDOWUPDATE  As Long = &H400&
Private Const DCX_NORECOMPUTE       As Long = &H100000
Private Const DCX_NORESETATTRS      As Long = &H4&
Private Const DCX_PARENTCLIP        As Long = &H20&
Private Const DCX_VALIDATE          As Long = &H200000
Private Const DCX_WINDOW            As Long = &H1&

''
'' Ternary raster operations
''
Private Const SRCCOPY               As Long = &HCC0020      ' /* dest = source                   */
Private Const SRCPAINT              As Long = &HEE0086      ' /* dest = source OR dest           */
Private Const SRCAND                As Long = &H8800C6      ' /* dest = source AND dest          */
Private Const SRCINVERT             As Long = &H660046      ' /* dest = source XOR dest          */
Private Const SRCERASE              As Long = &H440328      ' /* dest = source AND (NOT dest )   */
Private Const NOTSRCCOPY            As Long = &H330008      ' /* dest = (NOT source)             */
Private Const NOTSRCERASE           As Long = &H1100A6      ' /* dest = (NOT src) AND (NOT dest) */
Private Const MERGECOPY             As Long = &HC000CA      ' /* dest = (source AND pattern)     */
Private Const MERGEPAINT            As Long = &HBB0226      ' /* dest = (NOT source) OR dest     */
Private Const PATCOPY               As Long = &HF00021      ' /* dest = pattern                  */
Private Const PATPAINT              As Long = &HFB0A09      ' /* dest = DPSnoo                   */
Private Const PATINVERT             As Long = &H5A0049      ' /* dest = pattern XOR dest         */
Private Const DSTINVERT             As Long = &H550009      ' /* dest = (NOT dest)               */
Private Const BLACKNESS             As Long = &H42&         ' /* dest = BLACK                    */
Private Const WHITENESS             As Long = &HFF0062      ' /* dest = WHITE                    */
'#if(WINVER >= 0x0500)

Private Const NOMIRRORBITMAP        As Long = &H80000000    ' /* Do not Mirror the bitmap in this call */
Private Const CAPTUREBLT            As Long = &H40000000    ' /* Include layered windows */
'#endif /* WINVER >= 0x0500 */

''
'' StretchBlt Modes
''
Private Const BLACKONWHITE          As Long = 1&
Private Const WHITEONBLACK          As Long = 2&
Private Const COLORONCOLOR          As Long = 3&
Private Const HALFTONE              As Long = 4&
Private Const MAXSTRETCHBLTMODE     As Long = 4&

'#if(WINVER >= 0x0400)
'/* New StretchBlt() Modes */
Private Const STRETCH_ANDSCANS      As Long = BLACKONWHITE
Private Const STRETCH_ORSCANS       As Long = WHITEONBLACK
Private Const STRETCH_DELETESCANS   As Long = COLORONCOLOR
Private Const STRETCH_HALFTONE      As Long = HALFTONE
'#endif /* WINVER >= 0x0400 */

'/*
' * DrawText() Format Flags
' */
Private Const DT_TOP                      As Long = &H0         '
Private Const DT_LEFT                     As Long = &H0         '
Private Const DT_CENTER                   As Long = &H1         '
Private Const DT_RIGHT                    As Long = &H2         '
Private Const DT_VCENTER                  As Long = &H4         '
Private Const DT_BOTTOM                   As Long = &H8         '
Private Const DT_WORDBREAK                As Long = &H10        '
Private Const DT_SINGLELINE               As Long = &H20        '
Private Const DT_EXPANDTABS               As Long = &H40        '
Private Const DT_TABSTOP                  As Long = &H80        '
Private Const DT_NOCLIP                   As Long = &H100       '
Private Const DT_EXTERNALLEADING          As Long = &H200       '
Private Const DT_CALCRECT                 As Long = &H400       '
Private Const DT_NOPREFIX                 As Long = &H800       '
Private Const DT_INTERNAL                 As Long = &H1000      '

'#if(WINVER >= 0x0400)
Private Const DT_EDITCONTROL              As Long = &H2000      '
Private Const DT_PATH_ELLIPSIS            As Long = &H4000      '
Private Const DT_END_ELLIPSIS             As Long = &H8000      '
Private Const DT_MODIFYSTRING             As Long = &H10000     '
Private Const DT_RTLREADING               As Long = &H20000     '
Private Const DT_WORD_ELLIPSIS            As Long = &H40000     '
'#if(WINVER >= 0x0500)
Private Const DT_NOFULLWIDTHCHARBREAK     As Long = &H80000     '
'#if(_WIN32_WINNT >= 0x0500)
Private Const DT_HIDEPREFIX               As Long = &H100000    '
Private Const DT_PREFIXONLY               As Long = &H200000    '
'#endif /* _WIN32_WINNT >= 0x0500 */
'#endif /* WINVER >= 0x0500 */

''
'' Other
''
Private Const LOGPIXELSY            As Long = 90&       '  Logical pixels/inch in Y
Private Const DEFAULT_CHARSET       As Long = 1&
Private Const OUT_DEFAULT_PRECIS    As Long = 0&
Private Const CLIP_DEFAULT_PRECIS   As Long = 0&
Private Const DRAFT_QUALITY         As Long = 1&
Private Const DEFAULT_PITCH         As Long = 0&
Private Const FF_DONTCARE           As Long = 0&   '  Don't care or don't know.
Private Const WM_SETFONT            As Long = &H30&
Private Const CLR_INVALID           As Long = &HFFFF&
Private Const COLOR_BTNTEXT = 18
Private Const COLOR_BTNFACE = 15

''
'' SetBkMode
''
Private Const OPAQUE                As Long = 2&
Private Const TRANSPARENT           As Long = 1&

''
'' FormatMessage
''

Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER As Long = &H100&
Private Const FORMAT_MESSAGE_IGNORE_INSERTS  As Long = &H200&
Private Const FORMAT_MESSAGE_FROM_STRING     As Long = &H400&
Private Const FORMAT_MESSAGE_FROM_HMODULE    As Long = &H800&
Private Const FORMAT_MESSAGE_FROM_SYSTEM     As Long = &H1000&
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY  As Long = &H2000&
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK  As Long = &HFF&


''
'' structs
''

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

Private Type DRAWTEXTPARAMS
    cbSize          As Long
    iTabLength      As Long
    iLeftMargin     As Long
    iRightMargin    As Long
    uiLengthDrawn   As Long
End Type

Private Type POINTAPI
    x               As Long
    y               As Long
End Type

''
'' Declare:いらん関数がいっぱいあるけど・・
''

''
'' kernel32
''
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, lpBuffer As Any, ByVal nSize As Long, Arguments As Long) As Long

''
'' user32
''
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDCEx Lib "user32" (ByVal hWnd As Long, ByVal hRgnClip As Long, ByVal fdwOptions As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, lpCursorName As Any) As Long
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As Any) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hdc As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, lpDrawTextParams As Any) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

''
'' gdi32
''
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function StretchDIBits Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal wSrcWidth As Long, ByVal wSrcHeight As Long, lpBits As Any, lpBitsInfo As Any, ByVal wUsage As Long, ByVal dwRop As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Private Declare Function SetBrushOrgEx Lib "gdi32" (ByVal hdc As Long, ByVal nXOrg As Long, ByVal nYOrg As Long, lppt As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal h As Long, ByVal w As Long, ByVal E As Long, ByVal O As Long, ByVal w As Long, ByVal i As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function PathToRegion Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Const WHITE_BRUSH = 0




Private Function CreateCompatibleMemoryDC(ByVal phSourceDC As OLE_HANDLE, ByVal plngCX As Long, ByVal plngCY As Long, phRetDC As OLE_HANDLE, phRetBitmap As OLE_HANDLE) As Boolean
Dim lngRet      As Long
       
    CreateCompatibleMemoryDC = False
On Error GoTo ERR_HANDLER_00
    
    
    '' 互換性のあるメモリDCを作る
    phRetDC = CreateCompatibleDC(phSourceDC)
    If (0& = phRetDC) Then
        Call DllErrRaise(Err.LastDllError, "CreateCompatibleDC")
    Else
        '' 互換性のあるビットマップを作る
        phRetBitmap = CreateCompatibleBitmap(phSourceDC, plngCX, plngCY)
        If (0& = phRetBitmap) Then
            Call DllErrRaise(Err.LastDllError, "CreateCompatibleBitmap")
        Else
            '' DCにビットマップを選択する
            lngRet = SelectObject(phRetDC, phRetBitmap)
            If (0& = lngRet) Then
                Call DllErrRaise(Err.LastDllError, "SelectObject")
            Else
                '' 正常終了
                CreateCompatibleMemoryDC = True
                Exit Function
''------------->以降は異常時の処理
            End If
            '' ビットマップ削除
            Call DeleteObject(phRetBitmap)
            phRetBitmap = 0&
        End If
        '' DC削除
        Call DeleteDC(phRetDC)
        phRetDC = 0&
    End If
    Exit Function
ERR_HANDLER_00:
    
    Call MsgBox(CStr(Err.Number) & ":" & Err.Source & vbCr & Err.Description & vbCr & "(CreateCompatibleMemoryDC)", vbCritical, "ERROR")
    Resume Next
End Function

Private Function DrawSampleTextToDC(ByVal phDestDC As OLE_HANDLE, pudtDestRect As RECT) As Boolean
Dim lngRet          As Long
Dim hFont           As OLE_HANDLE

    DrawSampleTextToDC = False
On Error GoTo ERR_HANDLER_00
    
    '' 文字色
    lngRet = SetTextColor(phDestDC, GetSysColor(COLOR_BTNTEXT))
    If lngRet = CLR_INVALID Then
        Call DllErrRaise(Err.LastDllError, "SetTextColor")
    Else
        '' 背景透過
        lngRet = SetBkMode(phDestDC, TRANSPARENT)
        If lngRet = 0& Then
            Call DllErrRaise(Err.LastDllError, "SetBkMode")
        Else
    
            '' 背景色
            lngRet = SetBkColor(phDestDC, GetSysColor(COLOR_BTNFACE))
            If lngRet = CLR_INVALID Then
                Call DllErrRaise(Err.LastDllError, "SetBkColor")
            Else
                
                '' フォントオブジェクト作成
                hFont = CreateFont(-MulDiv(Me.Font.Size, GetDeviceCaps(Me.hdc, LOGPIXELSY), 72) _
                        , 0&, 0&, 0& _
                        , IIf(Me.Font.Bold, 700, 100&), Me.Font.Italic, Me.Font.Underline, Me.Font.Strikethrough _
                        , DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DRAFT_QUALITY, DEFAULT_PITCH Or FF_DONTCARE, Me.Font.Name)
                If hFont = 0& Then
                    Call DllErrRaise(Err.LastDllError, "CreateFont")
                Else
                    '' フォントをDCに選択
                    lngRet = SelectObject(phDestDC, hFont)
                    If lngRet = 0& Then
                        Call DllErrRaise(Err.LastDllError, "SelectObject")
                    Else
                    
    ''''                    With udtDrawParams
    ''''                        .cbSize = Len(udtDrawParams)
    ''''                        .iLeftMargin = 0&
    ''''                        .iRightMargin = 0&
    ''''                        .iTabLength = 0&
    ''''                        .uiLengthDrawn = 0&
    ''''                    End With
                        '' テキストを描画する
                        lngRet = DrawTextEx(phDestDC, "文字を書くサンプル", -1&, pudtDestRect, DT_WORDBREAK Or DT_NOPREFIX, ByVal 0&)
                        If lngRet = 0& Then
                            Call DllErrRaise(Err.LastDllError, "DrawTextEx")
                        Else
                            DrawSampleTextToDC = True
                        End If
                    End If
                    '' フォントを削除する
                    Call DeleteObject(hFont)
                End If
            End If
        End If
    End If
    Exit Function
ERR_HANDLER_00:
    
    Call MsgBox(CStr(Err.Number) & ":" & Err.Source & vbCr & Err.Description & vbCr & "(DrawSampleTextToDC)", vbCritical, "ERROR")
    Resume Next
End Function

Private Sub Command1_Click()
Const clngZOOM  As Long = 15&
Dim lngRet      As Long
Dim hMemDc      As OLE_HANDLE
Dim hBitmap     As OLE_HANDLE
Dim lngCX       As Long
Dim lngCY       As Long
Dim udtRect     As RECT
Dim blnRet      As Boolean
    
On Error GoTo ERR_HANDLER_00
    With Me
        .AutoRedraw = True
        lngCX = .ScaleX(.ScaleWidth, .ScaleMode, vbPixels)
        lngCY = .ScaleY(.ScaleHeight, .ScaleMode, vbPixels)
        .Font.Size = 7& * clngZOOM
    End With
    udtRect.Left = 0&
    udtRect.Top = 0&
    udtRect.Right = lngCX * clngZOOM
    udtRect.Bottom = lngCY * clngZOOM
    blnRet = CreateCompatibleMemoryDC(Me.hdc, udtRect.Right, udtRect.Bottom, hMemDc, hBitmap)
    If blnRet Then
        '' 背景を転送
        lngRet = StretchBlt(hMemDc, 0&, 0&, udtRect.Right, udtRect.Bottom, Me.hdc, 0&, 0&, lngCX, lngCY, SRCCOPY)
        If 0& = lngRet Then
            Call DllErrRaise(Err.LastDllError, "StretchBlt")
        Else
            '' 縮小モードを設定→HALFTONEで。ほかにもいろいろ。
            lngRet = SetStretchBltMode(Me.hdc, HALFTONE)
            If 0& = lngRet Then
                Call DllErrRaise(Err.LastDllError, "SetStretchBltMode")
            Else
                '' ブラシずれを修正する(HALFTONE以外の時は不要)
                lngRet = SetBrushOrgEx(Me.hdc, 0&, 0&, ByVal 0&)
                If 0& = lngRet Then
                    Call DllErrRaise(Err.LastDllError, "SetBrushOrgEx")
                Else
                    '' 字を書く
                    blnRet = DrawSampleTextToDC(hMemDc, udtRect)
                    If blnRet Then
                        '' 転送:さっきの SetStretchBltMode のパラメータによって結果が変わる
                        lngRet = StretchBlt(Me.hdc, 0&, 0&, lngCX, lngCY, hMemDc, 0&, 0&, udtRect.Right, udtRect.Bottom, SRCCOPY)
                        If 0& = lngRet Then
                            Call DllErrRaise(Err.LastDllError, "StretchBlt")
                        Else
                            Call Me.Refresh
                        End If
                    End If
                End If
            End If
        End If
        Call DeleteObject(hBitmap)
        Call DeleteDC(hMemDc)
    End If
    Exit Sub
ERR_HANDLER_00:
    
    Call MsgBox(CStr(Err.Number) & ":" & Err.Source & vbCr & Err.Description & vbCr & "(Command1_Click)", vbCritical, "ERROR")
    Resume Next
End Sub

'******************************************************************
'プロシージャ名:  :DllErrRaise
'説明:            :Err.LastDllErrorよりエラーを発生する
'引数:            :plngLastDllError   I   Err.LastDllError
'                 :pstrErrSource      I   エラーソース文字列
'******************************************************************
Private Sub DllErrRaise(ByVal plngLastDllError As Long, pstrErrSource As String)
'============= Declare ==============
Const clngMAX_BUFFER            As Long = 1024&
Dim bytBuf(clngMAX_BUFFER - 1&) As Byte 'バッファ
Dim lngRet                      As Long 'APIの戻り値
Dim strErrDescription           As String

'============= Initiarize ===========
    If plngLastDllError = 0& Then
        Exit Sub
    End If
    Erase bytBuf
    strErrDescription = ""
'============= Main =================
    
    ' エラー値に対応するメッセージを取得する
    lngRet = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, _
                            ByVal 0&, _
                            plngLastDllError, _
                            0&, _
                            bytBuf(0), _
                            clngMAX_BUFFER, _
                            ByVal 0&)
    If lngRet Then
        strErrDescription = StrConv(LeftB(bytBuf, lngRet), vbUnicode)
    End If
    
    ' エラーを発生する
    Call Err.Raise(plngLastDllError Or vbObjectError, pstrErrSource, strErrDescription)
    
End Sub