[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『図形の余白を減らすには？』（サラマンダー）
よろしくお願いします。
図形を挿入しても余白部分が広いので、
例えばa1セルに図形を貼り付けても
余白部分が、かぶさってしまい、図形が貼り付きません。
余白部分を狭めるやり方がありましたら
教えてください。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
https://excel-ubara.com/excelvba5/EXCELVBA256.html
↑こちら様が参考になるかも。
私でしたら、画像編集ソフトで作り直すとか。。。(*^ ^*；)
m(__)m
（隠居Z） 2025/02/20(木) 12:51:44
リボンのユーザー設定→トリミングツールを追加すると、便利ですよ。
（私は、よく使います）
（おもひろ） 2025/02/20(木) 15:55:28
あれ・・・? これ挿入したのは「図形」なのか「図」なのかどちらなんでしょうね?
（白茶） 2025/02/21(金) 11:59:20
よく考えて直してみたら、ホントに「図形」だったんだとしても、 一旦「図」にラスタライズしてからトリミングなり何なりするしかない... ですか。結論変わんないっすね。^^;
失礼しました （白茶） 2025/02/21(金) 23:58:42
そして不意に思い出したんで、自学ノート晒しておきます。 簡易的な画像変形ツール... いや、まぁ「遊び道具」ですね。^^;
Option Explicit
#If False Then
Dim ImageLockMode
Const ImageLockModeRead = 1
Const ImageLockModeWrite = 2
Const ImageLockModeUserInputBuf = 4
Dim RotateFlipType
Const RotateNoneFlipNone = 0
Const Rotate90FlipNone = 1
Const Rotate180FlipNone = 2
Const Rotate270FlipNone = 3
Const RotateNoneFlipX = 4
Const Rotate90FlipX = 5
Const Rotate180FlipX = 6
Const Rotate270FlipX = 7
Const RotateNoneFlipY = 6
Const Rotate90FlipY = 7
Const Rotate180FlipY = 4
Const Rotate270FlipY = 5
Const RotateNoneFlipXY = 2
Const Rotate90FlipXY = 3
Const Rotate180FlipXY = 0
Const Rotate270FlipXY = 1
Dim MatrixOrder
Const MatrixOrderPrepend = 0
Const MatrixOrderAppend = 1
Dim InterpolationMode
Const InterpolationModeInvalid = -1
Const InterpolationModeDefault = 0&
Const InterpolationModeLowQuality = 1&
Const InterpolationModeHighQuality = 2&
Const InterpolationModeBilinear = 3&
Const InterpolationModeBicubic = 4&
Const InterpolationModeNearestNeighbor = 5&
Const InterpolationModeHighQualityBilinear = 6&
Const InterpolationModeHighQualityBicubic = 7&
Dim PixelOffsetMode
Const PixelOffsetModeInvalid = -1
Const PixelOffsetModeDefault = 0
Const PixelOffsetModeHighSpeed = 1
Const PixelOffsetModeHighQuality = 2
Const PixelOffsetModeNone = 3
Const PixelOffsetModeHalf = 4
Dim PixelFormat
Const PixelFormat1bppIndexed = &H30101
Const PixelFormat4bppIndexed = &H30402
Const PixelFormat8bppIndexed = &H30803
Const PixelFormat16bppGreyScale = &H101004
Const PixelFormat16bppRGB555 = &H21005
Const PixelFormat16bppRGB565 = &H21006
Const PixelFormat16bppARGB1555 = &H61007
Const PixelFormat24bppRGB = &H21808
Const PixelFormat32bppRGB = &H22009
Const PixelFormat32bppARGB = &H26200A
Const PixelFormat32bppPARGB = &HE200B
Const PixelFormat48bppRGB = &H10300C
Const PixelFormat64bppARGB = &H34400D
Const PixelFormat64bppPARGB = &H1C400E
Dim GpUnit
Const UnitWorld = 0
Const UnitDisplay = 1
Const UnitPixel = 2
Const UnitPoint = 3
Const UnitInch = 4
Const UnitDocument = 5
Const UnitMillimeter = 6
Dim DashStyle
Const DashStyleSolid = 0
Const DashStyleDash = 1
Const DashStyleDot = 2
Const DashStyleDashDot = 3
Const DashStyleDashDotDot = 4
Const DashStyleCustom = 5
Dim SmoothingMode
Const SmoothingModeInvalid = -1
Const SmoothingModeDefault = 0
Const SmoothingModeHighSpeed = 1
Const SmoothingModeHighQuality = 2
Const SmoothingModeNone = 3
Const SmoothingModeAntiAlias = 4
Dim ColorAdjustType
Const ColorAdjustTypeDefault = 0
Const ColorAdjustTypeBitmap = 1
Const ColorAdjustTypeBrush = 2
Const ColorAdjustTypePen = 3
Const ColorAdjustTypeText = 4
Const ColorAdjustTypeCount = 5
Const ColorAdjustTypeAny = 6
Dim WrapMode
Const WrapModeTile = 0
Const WrapModeTileFlipX = 1
Const WrapModeTileFlipY = 2
Const WrapModeTileFlipXY = 3
Const WrapModeClamp = 4
Dim HatchStyle
Const HatchStyleSmallCheckerBoard = 49
Const HatchStyleLargeCheckerBoard = 50
#End If
Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
'Private Const SM_CXSCREEN As Long = 0 'プライマリディスプレイの幅
'Private Const SM_CYSCREEN As Long = 1 'プライマリディスプレイの高さ
'Private Const SM_CYCAPTION As Long = 4 '標準タイトルバーの高さ
'Private Const SM_CXBORDER As Long = 5 '非立体的なウィンドウの枠線の幅
'Private Const SM_CYBORDER As Long = 6 '非立体的なウィンドウの枠線の高さ
'Private Const SM_CXDLGFRAME As Long = 7 'タイトルバー付きサイズ変更不可ウィンドウの枠の幅
'Private Const SM_CYDLGFRAME As Long = 8 'タイトルバー付きサイズ変更不可ウィンドウの枠の高さ
'Private Const SM_CYMENU As Long = 15 '一行分のメニューバーの高さ
Private Const SM_CYVSCROLL As Long = 20 '垂直スクロールバー上下にある矢印ボタンの高さ
Private Const SM_CXHSCROLL As Long = 21 '水平スクロールバー左右にある矢印ボタンの幅
'Private Const SM_CXFRAME As Long = 32 'サイズ可変ウィンドウの枠の幅
'Private Const SM_CYFRAME As Long = 33 'サイズ可変ウィンドウの枠の高さ
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As LongPtr
hPal As LongPtr
Reserved As Long
End Type
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As Long
'Private Const PICTYPE_UNINITIALIZED = -1&
'Private Const PICTYPE_NONE = 0&
Private Const PICTYPE_BITMAP = 1&
'Private Const PICTYPE_METAFILE = 2&
'Private Const PICTYPE_ICON = 3&
'Private Const PICTYPE_ENHMETAFILE = 4&
Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As LongPtr
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (ByRef token As LongPtr, ByRef inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal bitmap As LongPtr, hbmReturn As LongPtr, ByVal background As Long) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, bitmap As LongPtr) As Long
Private Enum RotateFlipType
RotateNoneFlipNone = 0 '時計回りの回転も反転も行わないことを指定します。
Rotate90FlipNone = 1 '反転せずに時計回りに 90 度回転することを指定します。
Rotate180FlipNone = 2 '反転せずに時計回りに 180 度回転することを指定します。
Rotate270FlipNone = 3 '反転せずに時計回りに 270 度回転することを指定します。
RotateNoneFlipX = 4 '時計回りに回転せずに水平方向に反転することを指定します。
' Rotate90FlipX = 5 '時計回りに 90 度回転してから、水平方向に反転することを指定します。
' Rotate180FlipX = 6 '時計回りに 180 度回転してから、水平方向に反転することを指定します。
' Rotate270FlipX = 7 '時計回りに 270 度回転してから、水平方向に反転することを指定します。
RotateNoneFlipY = 6 '時計回りに回転せずに垂直方向に反転することを指定します。
' Rotate90FlipY = 7 '時計回りに 90 度回転してから、垂直方向に反転することを指定します。
' Rotate180FlipY = 4 '時計回りに 180 度回転してから、垂直方向に反転することを指定します。
' Rotate270FlipY = 5 '時計回りに 270 度回転してから、垂直方向に反転することを指定します。
' RotateNoneFlipXY = 2 '時計回りに回転せずに水平方向と垂直方向に反転することを指定します。
' Rotate90FlipXY = 3 '時計回りに 90 度回転してから、水平方向と垂直方向に反転することを指定します。
' Rotate180FlipXY = 0 '時計回りに 180 度回転してから、水平方向と垂直方向に反転することを指定します。
' Rotate270FlipXY = 1 '時計回りに 270 度回転してから、水平方向と垂直方向に反転することを指定します。
End Enum
Private Declare PtrSafe Function GdipImageRotateFlip Lib "gdiplus.dll" (ByVal Image As LongPtr, ByVal rfType As RotateFlipType) As Long
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Enum MatrixOrder '新しい行列に既存の行列を乗算する場合の乗算の順序を指定します。
MatrixOrderPrepend = 0 '新しい行列が左側にあり、既存の行列が右側にあることを指定します。
MatrixOrderAppend = 1 '既存の行列が左側にあり、新しい行列が右側にあることを指定します。
End Enum
Private Enum PixelFormat
' PixelFormat1bppIndexed = &H30101 '1ピクセルあたり1ビットのインデックス付き。したがって、カラーテーブルには2色含まれています。
' PixelFormat4bppIndexed = &H30402 '1ピクセルあたり4ビットのインデックス付き。
' PixelFormat8bppIndexed = &H30803 '1ピクセルあたり8ビットのインデックス付き。したがって、カラーテーブルには256色含まれています。
' PixelFormat16bppGreyScale = &H101004 '1ピクセルあたり16ビット。このカラー情報は、65,536種類の灰色の濃淡を指定します。
' PixelFormat16bppRGB555 = &H21005 '1ピクセルあたり16ビット。赤緑青のコンポーネントに、それぞれ5ビットを使用します。残りのビットは使用されません。
' PixelFormat16bppRGB565 = &H21006 '1ピクセルあたり16ビット。そのうちの5ビットが赤のコンポーネント、6ビットが緑のコンポーネント、5ビットが青のコンポーネントに使用されることを指定します。
' PixelFormat16bppARGB1555 = &H61007 '1ピクセルあたり16ビット。このカラー情報は、32,768種類の色の濃淡を指定します。この情報の5ビットが赤、5ビットが緑、5ビットが青、1ビットがアルファです。
' PixelFormat24bppRGB = &H21808 '1ピクセルあたり24ビット。赤緑青のコンポーネントに、それぞれ8ビットを使用します。
PixelFormat32bppRGB = &H22009 '1ピクセルあたり32ビット。赤緑青のコンポーネントに、それぞれ8ビットを使用します。残りの8ビットは使用されません。
PixelFormat32bppARGB = &H26200A '1ピクセルあたり32ビット。アルファ、赤緑青のコンポーネントに、それぞれ8ビットを使用します。
' PixelFormat32bppPARGB = &HE200B '1ピクセルあたり32ビット。アルファ、赤緑青のコンポーネントに、それぞれ8ビットを使用します。アルファコンポーネントに応じて赤緑青のコンポーネントが事前乗算されます。
' PixelFormat48bppRGB = &H10300C '1ピクセルあたり48ビット。赤緑青のコンポーネントに、それぞれ16ビットを使用します。
' PixelFormat64bppARGB = &H34400D '1ピクセルあたり64ビット。アルファ、赤緑青のコンポーネントに、それぞれ16ビットを使用します。
' PixelFormat64bppPARGB = &H1C400E '1ピクセルあたり64ビット。アルファ、赤緑青のコンポーネントに、それぞれ16ビットを使用します。アルファコンポーネントに応じて赤緑青のコンポーネントが事前乗算されます。
End Enum
Private Declare PtrSafe Function GdipLoadImageFromFile Lib "gdiplus" (ByVal FileName As LongPtr, ByRef Image As LongPtr) As Long
Private Declare PtrSafe Function GdipLoadImageFromStream Lib "gdiplus" (ByVal Stream As LongPtr, ByRef Image As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As Long
Private Declare PtrSafe Function GdipGetImageHeight Lib "gdiplus" (ByVal Image As LongPtr, ByRef Height As Long) As Long
Private Declare PtrSafe Function GdipGetImageWidth Lib "gdiplus" (ByVal Image As LongPtr, ByRef Width As Long) As Long
Private Declare PtrSafe Function GdipCloneImage Lib "gdiplus" (ByVal Image As LongPtr, cloneImage As LongPtr) As Long
Private Declare PtrSafe Function GdipCloneBitmapAreaI Lib "gdiplus" (ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long, ByVal PixelFormat As PixelFormat, ByVal srcBitmap As LongPtr, dstBitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal nWidth As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, ByRef scan0 As Any, ByRef nBitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal Image As LongPtr, graphics As LongPtr) As Long
Private Declare PtrSafe Function GdipDrawImageRectI Lib "gdiplus.dll" (ByVal GpGraphics As LongPtr, ByVal GpImage As LongPtr, ByVal Left As Long, ByVal Top As Long, ByVal Width As Long, ByVal Height As Long) As Long
Private Enum GpUnit '特定のデータ型の測定単位を指定します。
UnitWorld = 0 '非物理単位であるワールド座標を指定します。
UnitDisplay = 1 '表示単位を指定します。 たとえば、ディスプレイ デバイスがモニターの場合、単位は 1 ピクセルです。
UnitPixel = 2 '単位が 1 ピクセルであることを指定します。
UnitPoint = 3 '単位が 1 ポイントまたは 1/72 インチであることを指定します。
UnitInch = 4 '単位が 1 インチであることを指定します。
UnitDocument = 5 '単位が 1/300 インチであることを指定します。
UnitMillimeter = 6 '単位が 1 mm であることを指定します。
End Enum
Private Declare PtrSafe Function GdipDrawImageRectRectI Lib "gdiplus" (ByVal graphics As LongPtr, ByVal Image As LongPtr, _
ByVal dstX As Long, ByVal dstY As Long, ByVal dstWidth As Long, ByVal dstHeight As Long, _
ByVal srcx As Long, ByVal srcy As Long, ByVal SrcWidth As Long, ByVal SrcHeight As Long, ByVal srcUnit As GpUnit, _
Optional ByVal imageAttributes As LongPtr = 0, Optional ByVal callback As LongPtr = 0, Optional ByVal callbackData As LongPtr = 0) As Long
Private Declare PtrSafe Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As LongPtr) As Long
Private Declare PtrSafe Function GdipTranslateWorldTransform Lib "gdiplus" (ByVal graphics As LongPtr, ByVal dx As Single, ByVal dy As Single, ByVal order As MatrixOrder) As Long
Private Declare PtrSafe Function GdipRotateWorldTransform Lib "gdiplus" (ByVal graphics As LongPtr, ByVal Angle As Single, ByVal order As MatrixOrder) As Long
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
TypeAPI As Long
Value As LongPtr
End Type
Private Type EncoderParameters
Count As Long
Parameter(0 To 15) As EncoderParameter
End Type
Private Declare PtrSafe Function GdipGetImageHorizontalResolution Lib "gdiplus" (ByVal Image As LongPtr, resolution As Single) As Long
Private Declare PtrSafe Function GdipGetImageVerticalResolution Lib "gdiplus" (ByVal Image As LongPtr, resolution As Single) As Long
Private Declare PtrSafe Function GdipBitmapSetResolution Lib "gdiplus" (ByVal pbitmap As LongPtr, ByVal xdpi As Single, ByVal ydpi As Single) As Long
Private Enum ImageLockMode
ImageLockModeRead = 1
ImageLockModeWrite = 2
ImageLockModeUserInputBuf = 4
End Enum
Private Type BITMAPDATA
Width As Long 'Bitmapオブジェクトの幅(ピクセル単位)を取得または設定します。これを1つのスキャンラインのピクセル数と考えることもできます。
Height As Long 'Bitmapオブジェクトの高さ(ピクセル単位)を取得または設定します。スキャンラインの数を指す場合もあります。
stride As Long 'Bitmapオブジェクトのストライド幅 (スキャン幅とも呼ばれる)を取得または設定します。
' ストライドは、1行のピクセル(スキャンライン)の幅で、4バイトの境界に切り上げられます。
' ストライドが正の場合、ビットマップは上から下に表示されます。
' ストライドが負の場合、ビットマップはボトムアップになります。
PixelFormat As Long 'このBitmapDataオブジェクトを返したBitmapオブジェクトに格納されているピクセル情報の形式を取得または設定します。
scan0 As LongPtr 'ビットマップ内の最初のピクセル データのアドレス。
Reserved As LongPtr '予約済み。使用しないでください。
End Type
Private Declare PtrSafe Function GdipBitmapLockBits Lib "gdiplus" (ByVal bitmap As LongPtr, ByRef RECT As Any, ByVal flags As Long, ByVal PixelFormat As PixelFormat, ByRef lockedBitmapData As Any) As Long
Private Declare PtrSafe Function GdipBitmapUnlockBits Lib "gdiplus" (ByVal bitmap As LongPtr, ByRef lockedBitmapData As Any) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, ByRef pCLSID As GUID) As Long
Private Const CLSID_BMP As String = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_GIF As String = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_TIF As String = "{557CF405-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_PNG As String = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_JPG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const QUALITY_PARAMS As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As LongPtr, ByVal FileName As LongPtr, ByRef clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare PtrSafe Function GdipSaveImageToStream Lib "gdiplus" (ByVal Image As LongPtr, ByVal Stream As LongPtr, ByRef clsidEncoder As GUID, ByVal encoderParams As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromGraphics Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal graphics As LongPtr, bitmap As LongPtr) As Long
Private Enum InterpolationMode 'イメージをスケーリングまたは回転するときに使用されるアルゴリズムを指定します
InterpolationModeInvalid = -1 '内部的に使用される
InterpolationModeDefault = 0& '既定の補間モードを指定します。
InterpolationModeLowQuality = 1& '低品質モードを指定します。
InterpolationModeHighQuality = 2& '高品質モードを指定します。
InterpolationModeBilinear = 3& '双一次補間を指定します。 事前フィルター処理は実行されません。このモードは、イメージを元のサイズの 50% 以下にするような縮小処理には適していません。
InterpolationModeBicubic = 4& '双三次補間を指定します。 事前フィルター処理は実行されません。このモードは、イメージを元のサイズの 25% 以下にするような縮小処理には適していません。
InterpolationModeNearestNeighbor = 5& '最近傍補間を指定します。
InterpolationModeHighQualityBilinear = 6& '高品質双一次補間を指定します。 事前フィルター処理が適用され、高品質の縮小処理が実行されます。
InterpolationModeHighQualityBicubic = 7& '高品質双三次補間を指定します。 事前フィルター処理が適用され、高品質の縮小処理が実行されます。 このモードを使用すると、変換後のイメージが高品質になります。
End Enum
Private Declare PtrSafe Function GdipSetInterpolationMode Lib "gdiplus" (ByVal graphics As LongPtr, ByVal nInterpolationMode As InterpolationMode) As Long
Private Enum PixelOffsetMode 'Graphics オブジェクトのピクセル オフセット モードを指定します。
PixelOffsetModeInvalid = -1 '内部使用。
PixelOffsetModeDefault = 0 'PixelOffsetModeNone と同じです。
PixelOffsetModeHighSpeed = 1 'PixelOffsetModeNone と同じです。
PixelOffsetModeHighQuality = 2 'PixelOffsetModeHalf と同等です。
PixelOffsetModeNone = 3 'ピクセルの中心に整数座標があることを示します。
PixelOffsetModeHalf = 4 'ピクセルの中心に整数値の中間の座標があることを示します。
End Enum
Private Declare PtrSafe Function GdipSetPixelOffsetMode Lib "gdiplus" (ByVal graphics As LongPtr, ByVal PixOffsetMode As PixelOffsetMode) As Long
Private Declare PtrSafe Function GdipCreatePen1 Lib "gdiplus" (ByVal color As Long, ByVal Width As Single, ByVal unit As GpUnit, pen As LongPtr) As Long
Private Declare PtrSafe Function GdipCreatePen2 Lib "gdiplus" (ByVal Brush As LongPtr, ByVal Width As Single, ByVal unit As GpUnit, pen As LongPtr) As Long
Private Declare PtrSafe Function GdipDeletePen Lib "gdiplus" (ByVal pen As LongPtr) As Long
Private Declare PtrSafe Function GdipDrawRectangleI Lib "gdiplus" (ByVal graphics As LongPtr, ByVal pen As LongPtr, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long) As Long
Private Enum DashStyle
DashStyleSolid = 0 '実線を指定します。
DashStyleDash = 1 '破線を指定します。
DashStyleDot = 2 '点線を指定します。
DashStyleDashDot = 3 '交互の破線を指定します。
DashStyleDashDotDot = 4 '交互の点線を指定します。
DashStyleCustom = 5 'ユーザー定義のカスタム破線を指定します。
End Enum
Private Declare PtrSafe Function GdipSetPenDashStyle Lib "gdiplus" (ByVal pen As LongPtr, ByVal dStyle As DashStyle) As Long
Private Enum SmoothingMode '線と曲線に適用されるスムージング (アンチエイリアシング) の種類を指定します。
SmoothingModeInvalid = -1 '無効なモードを指定します。
SmoothingModeDefault = 0 'アンチエイリアス処理しないことを指定します。
SmoothingModeHighSpeed = 1 'アンチエイリアス処理しないことを指定します。
SmoothingModeHighQuality = 2 'アンチエイリアス処理されたレタリングを指定します。
SmoothingModeNone = 3 'アンチエイリアス処理しないことを指定します。
SmoothingModeAntiAlias = 4 'アンチエイリアス処理されたレタリングを指定します。
End Enum
Private Declare PtrSafe Function GdipGetSmoothingMode Lib "gdiplus" (ByVal graphics As LongPtr, SmoothingMd As SmoothingMode) As Long
Private Declare PtrSafe Function GdipSetSmoothingMode Lib "gdiplus" (ByVal graphics As LongPtr, ByVal SmoothingMd As SmoothingMode) As Long
Private Enum ColorAdjustType '色の調整情報を使用する GDI+ オブジェクトを指定します。
ColorAdjustTypeDefault = 0 '独自の色の調整情報がないすべての GDI+ オブジェクトにより使用される色の調整情報。
ColorAdjustTypeBitmap = 1 'Bitmap オブジェクトの色の調整情報。
ColorAdjustTypeBrush = 2 'Brush オブジェクトの色の調整情報。
ColorAdjustTypePen = 3 'Pen オブジェクトの色の調整情報。
ColorAdjustTypeText = 4 'テキストの色の調整情報。
ColorAdjustTypeCount = 5 '指定した型の数。
ColorAdjustTypeAny = 6 'Reserved
End Enum
Private Declare PtrSafe Function GdipCreateImageAttributes Lib "gdiplus" (imageattr As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImageAttributes Lib "gdiplus" (ByVal imageattr As LongPtr) As Long
Private Declare PtrSafe Function GdipSetImageAttributesColorKeys Lib "gdiplus" (ByVal imageattr As LongPtr, ByVal ClrAdjType As ColorAdjustType, ByVal enableFlag As Boolean, ByVal colorLow As Long, ByVal colorHigh As Long) As Long
Private Enum WrapMode 'イメージの繰り返しコピーを使用して領域を並べて表示する方法を指定します。
WrapModeTile = 0 '反転せずにタイルを指定します。
WrapModeTileFlipX = 1 '1 つのタイルから行の次のタイルに移動するときに、タイルを水平方向に反転するように指定します。
WrapModeTileFlipY = 2 '列内の 1 つのタイルから次のタイルに移動するときに、タイルを垂直方向に反転するように指定します。
WrapModeTileFlipXY = 3 '行に沿って移動するときにタイルを水平方向に反転し、列に沿って移動するときに垂直方向に反転することを指定します。
WrapModeClamp = 4 'タイリングが行われないことを指定します。
End Enum
Private Type POINTL
x As Long
y As Long
End Type
Private Declare PtrSafe Function GdipCreateSolidFill Lib "gdiplus" (ByVal argb As Long, Brush As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateLineBrushI Lib "gdiplus" (Point1 As POINTL, Point2 As POINTL, ByVal color1 As Long, ByVal color2 As Long, ByVal WrapMd As WrapMode, lineGradient As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateTexture Lib "gdiplus" (ByVal Image As LongPtr, ByVal WrapMd As WrapMode, texture As LongPtr) As Long
Private Declare PtrSafe Function GdipDeleteBrush Lib "gdiplus" (ByVal Brush As LongPtr) As Long
Private Declare PtrSafe Function GdipDrawLineI Lib "gdiplus" (ByVal graphics As LongPtr, ByVal pen As LongPtr, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Private Enum HatchStyle
' HatchStyleHorizontal = 0
' HatchStyleVertical = 1
' HatchStyleForwardDiagonal = 2
' HatchStyleBackwardDiagonal = 3
' HatchStyleCross = 4
' HatchStyleDiagonalCross = 5
' HatchStyle05Percent = 6
' HatchStyle10Percent = 7
' HatchStyle20Percent = 8
' HatchStyle25Percent = 9
' HatchStyle30Percent = 10
' HatchStyle40Percent = 11
' HatchStyle50Percent = 12
' HatchStyle60Percent = 13
' HatchStyle70Percent = 14
' HatchStyle75Percent = 15
' HatchStyle80Percent = 16
' HatchStyle90Percent = 17
' HatchStyleLightDownwardDiagonal = 18
' HatchStyleLightUpwardDiagonal = 19
' HatchStyleDarkDownwardDiagonal = 20
' HatchStyleDarkUpwardDiagonal = 21
' HatchStyleWideDownwardDiagonal = 22
' HatchStyleWideUpwardDiagonal = 23
' HatchStyleLightVertical = 24
' HatchStyleLightHorizontal = 25
' HatchStyleNarrowVertical = 26
' HatchStyleNarrowHorizontal = 27
' HatchStyleDarkVertical = 28
' HatchStyleDarkHorizontal = 29
' HatchStyleDashedDownwardDiagonal = 30
' HatchStyleDashedUpwardDiagonal = 31
' HatchStyleDashedHorizontal = 32
' HatchStyleDashedVertical = 33
' HatchStyleSmallConfetti = 34
' HatchStyleLargeConfetti = 35
' HatchStyleZigZag = 36
' HatchStyleWave = 37
' HatchStyleDiagonalBrick = 38
' HatchStyleHorizontalBrick = 39
' HatchStyleWeave = 40
' HatchStylePlaid = 41
' HatchStyleDivot = 42
' HatchStyleDottedGrid = 43
' HatchStyleDottedDiamond = 44
' HatchStyleShingle = 45
' HatchStyleTrellis = 46
' HatchStyleSphere = 47
' HatchStyleSmallGrid = 48
HatchStyleSmallCheckerBoard = 49
HatchStyleLargeCheckerBoard = 50
' HatchStyleOutlinedDiamond = 51
' HatchStyleSolidDiamond = 52
End Enum
Private Declare PtrSafe Function GdipCreateHatchBrush Lib "gdiplus" (ByVal style As HatchStyle, ByVal forecolr As Long, ByVal backcolr As Long, Brush As LongPtr) As Long
Private Declare PtrSafe Function GdipDrawEllipse Lib "gdiplus" (ByVal graphics As LongPtr, ByVal pen As LongPtr, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare PtrSafe Function GdipDrawLine Lib "gdiplus" (ByVal graphics As LongPtr, ByVal pen As LongPtr, ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single, ByVal y2 As Single) As Long
Private Declare PtrSafe Function GdipResetWorldTransform Lib "gdiplus" (ByVal graphics As LongPtr) As Long
Private Declare PtrSafe Function GdipFillRectangleI Lib "gdiplus" (ByVal graphics As LongPtr, ByVal Brush As LongPtr, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long) As Long
Rem ▽クリップボード関係----------------------------------------------------------------------------------------
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Const CF_BITMAP = 2& 'ビットマップのデータ(HBITMAP)
Private Declare PtrSafe Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As LongPtr, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare PtrSafe Function GetHGlobalFromStream Lib "ole32" (ByVal Stream As IUnknown, ByRef hGlobal As LongPtr) As Long
Rem ------------------------------------------------------------------------------------------------------------
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vkey As Long) As Integer
Private Declare PtrSafe Sub Sleep Lib "KERNEL32.dll" (ByVal dwMilliseconds As Long)
Rem ------------------------------------------------------------------------------------------------------------
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Type BITMAPINFOHEADER
biSize As Long '--- この構造体のサイズ (バイト数)
biWidth As Long '--- ビットマップの幅 (画素数) biCompression が BI_JPEG または BI_PNG の場合 biWidth は解凍された JPEG または PNG 画像の幅を表す
biHeight As Long '--- ビットマップの高さ (画素数)
' biHeight>0 ならボトムアップDIBで原点は左下隅。biHeight<0 ならトップダウンDIBで原点は左上隅。
' トップダウン DIB の場合 biCompression は BI_RGB または BI_BITFIELDS でなければならず圧縮はできない
' biCompression が BI_JPEG または BI_PNG の場合 biWidth は解凍された JPEG または PNG 画像の高さを表す
biPlanes As Integer '--- ターゲット・デバイスのプレーンの枚数(1でなければならない)
biBitCount As Integer '--- １画素当たりのビット数 (Bits-Per-Pixel，BPP)
biCompression As Long '--- ビットマップの圧縮方式を指定する トップダウン DIB は圧縮できない
biSizeImage As Long '--- ビットマップデータのサイズ (バイト数) BI_RGB(非圧縮形式) の場合は0でもよい
' BI_JPEG または BI_PNG の場合 biSizeImage はそれぞれ JPEG または PNG の画像バッファのサイズを示す
' 0やデタラメな値が入っていることがあるので アテにしてはいけない
' BI_RGB や BI_BITFIELDS の場合biSizeImage の正しい値は biWidth，biHeight，biBitCount から計算できるのでこの値を使う必要はない
biXPelsPerMeter As Long '--- ターゲット・デバイスの水平および垂直解像度 (単位は画素数/ｍ)
biYPelsPerMeter As Long ' アプリケーションはこれらの値を リソースグループの中からデバイスに最適なビットマップを選択するために使用してもよい
biClrUsed As Long '--- ビットマップが実際に使用するカラーテーブルのエントリ数
' biClrUsed=0 の場合ビットマップは biBitCount に対応する最大色数を使用する
' biClrUsed>0 かつ biBitCount<16 の場合biClrUsed は実際に使用される色数
' biBitCount>=16 の場合biClrUsed はシステムカラーパレットの性能を最適化するのに用いられるカラーテーブルのサイズ
' biBitCount=16 または 32 の場合最適カラーパレットは３つの DWORD マスクの直後から始まる
biClrImportant As Long '--- ビットマップを表示するのに必要な色数 (<=カラーテーブルのエントリ数)0ならばすべての色が必要(常に0を設定しておけばよし)
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
' bmiColors As RGBQUAD '当モジュールでは使わんので省略
End Type
Private Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal HBITMAP As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Const DIB_RGB_COLORS = 0&
Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Const IMAGE_BITMAP = 0&
Rem ▼その他変数・定数==========================================================================================
Private Type typeINT32
Value As Long
End Type
Private Type typeCOLORREF '0x00BBGGRR (COLORREF値 [Windows GDI]でRGB色を指定するDWORD値)
Red As Byte ' [OLE_COLOR]ってのは、このCOLORREF値か
Green As Byte ' あるいは
Blue As Byte ' 0x800000ii (iiは有効なGetSysColorインデックス)
NoData As Byte ' で表現されるシステムカラー。っていう定義
End Type
Private Type typeARGB '0xAARRGGBB (ARGB値 [.NET Framework]のColor構造体)
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
End Type
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private tkn As LongPtr, gi As GdiplusStartupInput, hImg As LongPtr, hTmp As LongPtr, pathImg As String, xdpiImg As Single, ydpiImg As Single
Private xdpi As Long, ydpi As Long, xlppi As Long, sbBtnHeight As Single, sbBtnWidth As Single
Private WithEvents Img1 As MSForms.Image, Frm1 As MSForms.Frame, ImgX As Single, ImgY As Single
Private WithEvents Btn1 As MSForms.CommandButton, WithEvents Btn2 As MSForms.CommandButton, WithEvents SBar1 As MSForms.ScrollBar, WithEvents Btn3 As MSForms.CommandButton
Private WithEvents Btn4 As MSForms.CommandButton, WithEvents Btn5 As MSForms.CommandButton
Private WithEvents Btn6 As MSForms.CommandButton, WithEvents Btn7 As MSForms.CommandButton
Private sAngle As Single, EventOff As Boolean, WithEvents TextAngle As MSForms.TextBox, WithEvents SpinAngle As MSForms.SpinButton
Private orgWidth As Long, orgHeight As Long
Private WithEvents TextCropRight As MSForms.TextBox, WithEvents TextCropBottom As MSForms.TextBox, WithEvents SpinCropRight As MSForms.SpinButton, WithEvents SpinCropBottom As MSForms.SpinButton
Private WithEvents TextCropTop As MSForms.TextBox, WithEvents TextCropLeft As MSForms.TextBox, WithEvents SpinCropTop As MSForms.SpinButton, WithEvents SpinCropLeft As MSForms.SpinButton
Private TextCropWidth As MSForms.TextBox, TextCropHeight As MSForms.TextBox
Private TextSrcWidth As MSForms.TextBox, TextSrcHeight As MSForms.TextBox
Private WithEvents ChkBxLockRect As MSForms.CheckBox, WithEvents ChkBxDrawRect As MSForms.CheckBox
Private LockedWidth As Long, LockedHeight As Long
Private WithEvents TextWidth As MSForms.TextBox, WithEvents TextHeight As MSForms.TextBox, WithEvents SpinWidth As MSForms.SpinButton, WithEvents SpinHeight As MSForms.SpinButton
Private WithEvents ChkBxLAR As MSForms.CheckBox
Private WithEvents ChkBxPOM As MSForms.CheckBox, WithEvents ComboInterpolationMode As MSForms.ComboBox
Private WithEvents ChkBxColorKey As MSForms.CheckBox, WithEvents ChkBxRGBSync As MSForms.CheckBox
Private WithEvents TextLowR As MSForms.TextBox, WithEvents TextLowG As MSForms.TextBox, WithEvents TextLowB As MSForms.TextBox
Private WithEvents TextHighR As MSForms.TextBox, WithEvents TextHighG As MSForms.TextBox, WithEvents TextHighB As MSForms.TextBox
Private WithEvents SpinLowR As MSForms.SpinButton, WithEvents SpinLowG As MSForms.SpinButton, WithEvents SpinLowB As MSForms.SpinButton
Private WithEvents SpinHighR As MSForms.SpinButton, WithEvents SpinHighG As MSForms.SpinButton, WithEvents SpinHighB As MSForms.SpinButton
Private TextPointR As MSForms.TextBox, TextPointG As MSForms.TextBox, TextPointB As MSForms.TextBox
Private WithEvents BtnHighColor As MSForms.CommandButton, WithEvents BtnLowColor As MSForms.CommandButton
Private ImgColorKeyGradient As MSForms.Image
Private WithEvents BtnPointColor As MSForms.ToggleButton, IsLooping As Boolean, LabelPickedColor As MSForms.Label, LabelPointColor As MSForms.Label, LabelPointColorMsg As MSForms.Label
Private WithEvents BtnBkColor As MSForms.CommandButton, BkColor1 As Long, BkColor2 As Long
Private WithEvents OptReal As MSForms.OptionButton, OptInt As MSForms.OptionButton
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Function GetDPI(nIndex As Long) As Long
Dim hDC As LongPtr
hDC = GetDC(Application.hWnd)
GetDPI = GetDeviceCaps(hDC, nIndex)
ReleaseDC &H0, hDC
End Function
Public Function Px2PtX(aPixel As Long) As Single
Px2PtX = Int((aPixel * xlppi / xdpi) / (xlppi / xdpi)) * (xlppi / xdpi) 'Int((px * 0.75) / 0.75) * 0.75
End Function
Public Function Pt2PxX(aPoint As Single) As Long
Pt2PxX = Int(aPoint * xdpi / xlppi)
End Function
Public Function Px2PtY(aPixel As Long) As Single
Px2PtY = Int((aPixel * xlppi / ydpi) / (xlppi / ydpi)) * (xlppi / ydpi)
End Function
Public Function Pt2PxY(aPoint As Single) As Long
Pt2PxY = Int(aPoint * ydpi / xlppi)
End Function
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Function CreatePictureByhBmp(ByVal hBmp As LongPtr, Optional hPal As LongPtr) As IPictureDisp
Dim IID_IDispatch As GUID, Bmp As PicBmp
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0&
.Data4(7) = &H46&
End With
With Bmp
.Size = Len(Bmp)
.Type = PICTYPE_BITMAP
.hBmp = hBmp
.hPal = hPal
End With
Call OleCreatePictureIndirect(Bmp, IID_IDispatch, 1, CreatePictureByhBmp)
End Function
Private Sub SaveToFile(hGpImg As LongPtr, FileName As String, Optional ByVal jpgQuarity As Long = 85)
Dim fGUID As GUID, p As EncoderParameters
Select Case UCase$(CreateObject("Scripting.FilesystemObject").GetExtensionName(FileName))
Case "JPG"
Call CLSIDFromString(StrPtr(CLSID_JPG), fGUID)
If jpgQuarity > 100 Then jpgQuarity = 100
If jpgQuarity < 1 Then jpgQuarity = 85
p.Count = 1
With p.Parameter(0)
Call CLSIDFromString(StrPtr(QUALITY_PARAMS), .GUID)
.TypeAPI = 4
.NumberOfValues = 1
.Value = VarPtr(jpgQuarity)
End With
Case "TIF": Call CLSIDFromString(StrPtr(CLSID_TIF), fGUID)
Case "GIF": Call CLSIDFromString(StrPtr(CLSID_GIF), fGUID)
Case "BMP": Call CLSIDFromString(StrPtr(CLSID_BMP), fGUID)
Case Else: Call CLSIDFromString(StrPtr(CLSID_PNG), fGUID)
End Select
If p.Count Then
Call GdipSaveImageToFile(hGpImg, StrPtr(FileName), fGUID, p)
Else
Call GdipSaveImageToFile(hGpImg, StrPtr(FileName), fGUID, ByVal 0&)
End If
End Sub
Private Function LoadImageToMeFromFile() As Boolean
Dim aPath As String
aPath = Application.GetOpenFilename("画像ファイル,*.png;*.jpg;*.gif;*.bmp")
If aPath = "False" Then Exit Function
If hImg Then
Call GdipDisposeImage(hImg)
hImg = 0
End If
If GdipLoadImageFromFile(StrPtr(aPath), hImg) = 0 Then
pathImg = aPath
Call GdipGetImageHorizontalResolution(hImg, xdpiImg)
Call GdipGetImageVerticalResolution(hImg, ydpiImg)
LoadImageToMeFromFile = True
End If
End Function
Private Function LoadImageToMeFromClipboard() As Boolean
Dim hPng As LongPtr, hBmp As LongPtr
hPng = GetPngfromClipboard
If hPng = 0 Then
hBmp = GetBmpfromClipboard
If hBmp = 0 Then Exit Function
End If
If hPng Then
Dim Stream As IUnknown
If hImg Then
Call GdipDisposeImage(hImg)
hImg = 0
End If
If CreateStreamOnHGlobal(ByVal hPng, 0, Stream) = 0 Then Call GdipLoadImageFromStream(ObjPtr(Stream), hImg)
pathImg = "Clipboard.png"
LoadImageToMeFromClipboard = True
Else
Call GdipCreateBitmapFromHBITMAP(hBmp, 0&, hImg)
pathImg = "Clipboard.png"
LoadImageToMeFromClipboard = True
End If
Call GdipGetImageHorizontalResolution(hImg, xdpiImg)
Call GdipGetImageVerticalResolution(hImg, ydpiImg)
End Function
Private Function SysColor2RGB(argInt32 As OLE_COLOR) As OLE_COLOR
If (argInt32 And &HFF000000) = &H80000000 Then
SysColor2RGB = GetSysColor(argInt32 And &HFFFFFF)
Else
SysColor2RGB = argInt32
End If
End Function
Private Sub SetMySize()
Dim maxW As Single, maxH As Single, c As MSForms.Control
Dim minTop As Single, minLeft As Single
For Each c In Me.Controls
If c.Parent Is Me And c.Visible Then
If c.Top + c.Height > maxH Then maxH = c.Top + c.Height
If c.Left + c.Width > maxW Then maxW = c.Left + c.Width
End If
Next
minTop = maxH
minLeft = maxW
For Each c In Me.Controls
If c.Parent Is Me And c.Visible Then
If c.Top >= 0 And c.Top < minTop Then minTop = c.Top
If c.Left >= 0 And c.Left < minLeft Then minLeft = c.Left
End If
Next
Me.Width = maxW + minLeft + (Me.Width - Me.InsideWidth)
Me.Height = maxH + minTop + (Me.Height - Me.InsideHeight)
End Sub
Private Function NumberedFilename(FileName As String, Optional Prefix As String, Optional Suffix As String) As String
Dim i As Long, p As String, b As String, e As String, fn As String
With CreateObject("Scripting.FilesystemObject")
p = .GetParentFolderName(FileName)
b = Prefix & .GetBaseName(FileName) & Suffix
e = .GetExtensionName(FileName)
fn = b & "." & e
i = 1
Do
NumberedFilename = .BuildPath(p, fn)
If Not .FileExists(NumberedFilename) Then Exit Do
i = i + 1
fn = b & Format$(i, " (0).") & e
Loop
End With
End Function
Private Function GetBitsFromHBITMAP(ByVal HBITMAP As LongPtr) As typeARGB()
Dim rtn As Long, pxWidth As Long, pxHeight As Long
Dim bi As BITMAPINFO
Dim hDC As LongPtr, hOld As LongPtr
Dim pxARGB() As typeARGB
hDC = CreateCompatibleDC(0&)
bi.bmiHeader.biSize = Len(bi.bmiHeader)
rtn = GetDIBits(hDC, HBITMAP, 0&, 0&, ByVal 0&, bi, DIB_RGB_COLORS)
If rtn Then
hOld = SelectObject(hDC, HBITMAP)
With bi.bmiHeader
pxWidth = .biWidth
pxHeight = Abs(.biHeight)
.biHeight = -pxHeight
.biPlanes = 1
.biBitCount = 32
.biCompression = 0
.biSizeImage = 0
End With
ReDim pxARGB(1 To pxWidth, 1 To pxHeight)
rtn = GetDIBits(hDC, HBITMAP, 0&, pxHeight, pxARGB(1, 1), bi, DIB_RGB_COLORS)
Call SelectObject(hDC, hOld)
GetBitsFromHBITMAP = pxARGB
End If
Call DeleteDC(hDC)
End Function
Private Function GetBits(hGpImg As LongPtr) As typeARGB()
Dim BmpData As BITMAPDATA
Dim px() As typeARGB, pxWidth As Long, pxHeight As Long
Call GdipGetImageWidth(hGpImg, pxWidth)
Call GdipGetImageHeight(hGpImg, pxHeight)
ReDim px(1 To pxWidth, 1 To pxHeight)
With BmpData
.Width = pxWidth
.Height = pxHeight
.PixelFormat = PixelFormat32bppARGB
.scan0 = VarPtr(px(1, 1))
.stride = pxWidth * 4
End With
Call GdipBitmapLockBits(hGpImg, ByVal 0, ImageLockModeUserInputBuf Or ImageLockModeRead, PixelFormat32bppARGB, BmpData)
Call GdipBitmapUnlockBits(hGpImg, BmpData)
GetBits = px
End Function
Private Function CreateFromBits(Bits() As typeARGB, Optional ByVal PixelFormat As PixelFormat = PixelFormat32bppARGB) As LongPtr
Dim pxWidth As Long, pxHeight As Long, hGpImg As LongPtr
pxWidth = UBound(Bits, 1) - LBound(Bits, 1) + 1
pxHeight = UBound(Bits, 2) - LBound(Bits, 2) + 1
If GdipCreateBitmapFromScan0(pxWidth, pxHeight, 0, PixelFormat32bppARGB, ByVal 0, hGpImg) = 0 Then
Dim BmpData As BITMAPDATA
With BmpData
.Width = pxWidth
.Height = pxHeight
.PixelFormat = PixelFormat32bppARGB
.scan0 = VarPtr(Bits(LBound(Bits, 1), LBound(Bits, 2)))
.stride = pxWidth * 4
End With
Call GdipBitmapLockBits(hGpImg, ByVal 0, ImageLockModeUserInputBuf Or ImageLockModeWrite, PixelFormat, BmpData)
Call GdipBitmapUnlockBits(hGpImg, BmpData)
CreateFromBits = hGpImg
End If
End Function
Private Function TrimTransparentPixels(srcGpImg As LongPtr) As LongPtr
Dim px() As typeARGB, pxWidth As Long, pxHeight As Long
Dim r As Long, c As Long
Dim pxLeft As Long, pxTop As Long, pxBottom As Long, pxRight As Long
Dim pxNew() As typeARGB, xdpiSrc As Single, ydpiSrc As Single
Call GdipGetImageHorizontalResolution(srcGpImg, xdpiSrc)
Call GdipGetImageVerticalResolution(srcGpImg, ydpiSrc)
px = GetBits(srcGpImg)
pxWidth = UBound(px, 1)
pxHeight = UBound(px, 2)
For c = 1 To pxWidth
For r = 1 To pxHeight
If px(c, r).Alpha > 0 Then
pxLeft = c
End If
If pxLeft Then Exit For
Next
If pxLeft Then Exit For
Next
For r = 1 To pxHeight
For c = 1 To pxWidth
If px(c, r).Alpha > 0 Then
pxTop = r
End If
If pxTop Then Exit For
Next
If pxTop Then Exit For
Next
For c = pxWidth To 1 Step -1
For r = pxHeight To 1 Step -1
If px(c, r).Alpha > 0 Then
pxRight = c
End If
If pxRight Then Exit For
Next
If pxRight Then Exit For
Next
For r = pxHeight To 1 Step -1
For c = pxWidth To 1 Step -1
If px(c, r).Alpha > 0 Then
pxBottom = r
End If
If pxBottom Then Exit For
Next
If pxBottom Then Exit For
Next
ReDim pxNew(pxLeft To pxRight, pxTop To pxBottom)
For c = pxLeft To pxRight
For r = pxTop To pxBottom
pxNew(c, r) = px(c, r)
Next
Next
TrimTransparentPixels = CreateFromBits(pxNew)
Call GdipBitmapSetResolution(TrimTransparentPixels, xdpiSrc, ydpiSrc)
End Function
Private Function szChrW(CodePoint As Variant) As String
Dim b() As Byte
If CodePoint >= &H10000 Then
Dim h As Long, l As Long
ReDim b(0 To 3) As Byte
h = (CodePoint - &H10000) \ &H400& + &HD800&
l = (CodePoint - &H10000) Mod &H400& + &HDC00&
b(1) = h \ &H100&: b(0) = h Mod &H100&
b(3) = l \ &H100&: b(2) = l Mod &H100&
Else
ReDim b(0 To 1) As Byte
b(1) = CodePoint \ &H100&: b(0) = CodePoint Mod &H100&
End If
szChrW = b
End Function
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'Private Function CopyBmptoClipboard(hBmp As LongPtr) As Boolean
' Call OpenClipboard(0&)
' Call EmptyClipboard
' CopyBmptoClipboard = CBool(SetClipboardData(CF_BITMAP, hBmp))
' Call CloseClipboard
'End Function
Private Function CopyPngtoClipboard(hGpImg As LongPtr) As Boolean
Call OpenClipboard(0&)
Call EmptyClipboard
Dim aStream As IUnknown, pngGUID As GUID
Call CreateStreamOnHGlobal(0&, 0&, aStream)
Call CLSIDFromString(StrPtr(CLSID_PNG), pngGUID)
If GdipSaveImageToStream(hGpImg, ByVal ObjPtr(aStream), pngGUID, 0) = 0 Then
Dim hGlobal As LongPtr, CF_PNG As Long
Call GetHGlobalFromStream(aStream, hGlobal)
If hGlobal Then
CF_PNG = RegisterClipboardFormat("PNG")
CopyPngtoClipboard = CBool(SetClipboardData(CF_PNG, hGlobal))
End If
End If
Call CloseClipboard
End Function
Private Function GetBmpfromClipboard() As LongPtr
If IsClipboardFormatAvailable(CF_BITMAP) = 0 Then Exit Function
If OpenClipboard(0&) <> 0 Then
GetBmpfromClipboard = GetClipboardData(CF_BITMAP)
Call CloseClipboard
End If
End Function
Private Function GetPngfromClipboard() As LongPtr
Dim CF_PNG As Long
CF_PNG = RegisterClipboardFormat("PNG")
If IsClipboardFormatAvailable(CF_PNG) = 0 Then Exit Function
If OpenClipboard(0&) <> 0 Then
GetPngfromClipboard = GetClipboardData(CF_PNG)
Call CloseClipboard
End If
End Function
Private Sub RotateImage()
If hImg = 0 Then Exit Sub
Dim pi As Single
pi = Atn(1) * 4
Dim hGrap As LongPtr, rtn As Long, hCrop As LongPtr, trmW As Long, trmH As Long
Dim sizeSQ As Long
sizeSQ = CLng(Sqr(ImgWidth ^ 2# + ImgHeight ^ 2#))
If hTmp Then
Call GdipDisposeImage(hTmp)
hTmp = 0
End If
Rem トリミング画像を準備
If rtn = 0 Then rtn = GdipCreateBitmapFromScan0(orgWidth, orgHeight, 0&, PixelFormat32bppARGB, ByVal 0&, hCrop)
If rtn = 0 Then rtn = GdipGetImageGraphicsContext(hCrop, hGrap)
trmW = orgWidth - SrcRight - SrcLeft
trmH = orgHeight - SrcBottom - SrcTop
If rtn = 0 Then rtn = GdipDrawImageRectRectI(hGrap, hImg, SrcLeft, SrcTop, trmW, trmH, SrcLeft, SrcTop, trmW, trmH, UnitPixel)
If hGrap Then
Call GdipDeleteGraphics(hGrap)
hGrap = 0
End If
Rem トリミング画像を元にスケーリング・回転画像を作成
If rtn = 0 Then rtn = GdipCreateBitmapFromScan0(sizeSQ, sizeSQ, 0&, PixelFormat32bppARGB, ByVal 0&, hTmp) '新しい画用紙を設置(画像の外接円が納まる正方形)
If rtn = 0 Then Call GdipBitmapSetResolution(hTmp, xdpiImg, ydpiImg)
If rtn = 0 Then rtn = GdipGetImageGraphicsContext(hTmp, hGrap) '描画用機材を画用紙初期位置に配置(座標原点は画用紙の左上隅で、ここが回転の中心でもある)
If rtn = 0 Then rtn = GdipSetInterpolationMode(hGrap, ComboInterpolationMode.ListIndex) '
If rtn = 0 Then rtn = GdipSetPixelOffsetMode(hGrap, IIf(ChkBxPOM.Value, PixelOffsetModeHalf, PixelOffsetModeNone)) '
If OptReal.Value Then
If rtn = 0 Then rtn = GdipTranslateWorldTransform(hGrap, -ImgWidth / 2!, -ImgHeight / 2!, MatrixOrderAppend) '機材を元画像の半サイズ分だけ左上方向に移動(画用紙左上隅に元画像の中心が来る感じにはみ出させる)
If rtn = 0 Then rtn = GdipRotateWorldTransform(hGrap, Angle, MatrixOrderAppend) '画用紙の左上隅を中心に機材を回す(このまま刷ったら画用紙には元画像の右下しか入らない)
If rtn = 0 Then rtn = GdipTranslateWorldTransform(hGrap, sizeSQ / 2!, sizeSQ / 2!, MatrixOrderAppend) '回した状態の機材を画用紙正面中央に移動(初期位置も通り過ぎて画用紙矩形内に元画像が納まる様に)
Else
If rtn = 0 Then rtn = GdipTranslateWorldTransform(hGrap, -Int(ImgWidth / 2), -Int(ImgHeight / 2), MatrixOrderAppend)
If rtn = 0 Then rtn = GdipRotateWorldTransform(hGrap, Angle, MatrixOrderAppend)
If rtn = 0 Then rtn = GdipTranslateWorldTransform(hGrap, Int(sizeSQ / 2), Int(sizeSQ / 2), MatrixOrderAppend)
End If
Rem カラーキー(透明度の範囲)の適用有無によって版刷り処理を分岐
If ChkBxColorKey.Value Then
Dim hAttr As LongPtr, ARGBHigh As typeARGB, ARGBLow As typeARGB, Int32High As typeINT32, Int32Low As typeINT32
ARGBHigh.Red = ColorKeyHighR
ARGBHigh.Green = ColorKeyHighG
ARGBHigh.Blue = ColorKeyHighB
ARGBHigh.Alpha = &HFF&
ARGBLow.Red = ColorKeyLowR
ARGBLow.Green = ColorKeyLowG
ARGBLow.Blue = ColorKeyLowB
ARGBLow.Alpha = &HFF&
LSet Int32High = ARGBHigh
LSet Int32Low = ARGBLow
If rtn = 0 Then rtn = GdipCreateImageAttributes(hAttr)
If rtn = 0 Then rtn = GdipSetImageAttributesColorKeys(hAttr, ColorAdjustTypeBitmap, True, Int32Low.Value, Int32High.Value)
If rtn = 0 Then rtn = GdipDrawImageRectRectI(hGrap, hCrop, 0, 0, ImgWidth, ImgHeight, 0, 0, orgWidth, orgHeight, UnitPixel, hAttr) '機材に元画像を彫って画用紙に刷る(トリミングとか色調補正加える場合はこっち)
If hAttr Then Call GdipDisposeImageAttributes(hAttr)
Else
If rtn = 0 Then rtn = GdipDrawImageRectI(hGrap, hCrop, 0, 0, ImgWidth, ImgHeight) '機材に元画像を彫って画用紙に刷る(ノーマル)
End If
If hCrop Then Call GdipDisposeImage(hCrop)
If rtn = 0 Then
Call UpdatePreviewPicture
Me.BackColor = &H8000000F
Else
Me.BackColor = &HFF&
End If
If hGrap Then Call GdipDeleteGraphics(hGrap)
'Debug.Print Now; "RotateImage"
End Sub
Private Sub UpdatePreviewPicture()
Dim hBmp As LongPtr, bkARGB As typeARGB, bkINT As typeINT32, bkOLE As typeCOLORREF
Dim rtn As Long, hGrap As LongPtr, hBrush As LongPtr, hPen As LongPtr, HBITMAP As LongPtr
Dim sizeSQ As Long
sizeSQ = CLng(Sqr(ImgWidth ^ 2# + ImgHeight ^ 2#))
If rtn = 0 Then rtn = GdipCloneImage(hTmp, hBmp)
If rtn = 0 Then rtn = GdipGetImageGraphicsContext(hBmp, hGrap)
' If rtn = 0 Then rtn = GdipCreateHatchBrush(HatchStyleLargeCheckerBoard, &HFFFFFFFF, bkINT.Value, hBrush)
Dim c1 As typeARGB, c2 As typeARGB, c32 As typeINT32
c32.Value = BkColor1
LSet c1 = c32
c32.Value = BkColor2
LSet c2 = c32
hBrush = CreateCheckerBoardTextureBrush(8, c1, c2)
If rtn = 0 Then rtn = GdipFillRectangleI(hGrap, hBrush, 0, 0, sizeSQ, sizeSQ)
If hBrush Then Call GdipDeleteBrush(hBrush): hBrush = 0
If rtn = 0 Then rtn = GdipDrawImageRectI(hGrap, hTmp, 0, 0, sizeSQ, sizeSQ)
If ChkBxDrawRect.Value Then
Rem ボックス外接円描画
If rtn = 0 Then rtn = GdipCreatePen1(IIf(BkColor1 > &HFF999999, &HFFFF0000, &HFFFFFF00), 1, UnitPixel, hPen)
If rtn = 0 Then rtn = GdipSetPenDashStyle(hPen, DashStyleDot)
If rtn = 0 Then rtn = GdipSetSmoothingMode(hGrap, SmoothingModeDefault)
If rtn = 0 Then rtn = GdipDrawLine(hGrap, hPen, sizeSQ / 2, 0, sizeSQ / 2, sizeSQ)
If rtn = 0 Then rtn = GdipDrawLine(hGrap, hPen, 0, sizeSQ / 2, sizeSQ, sizeSQ / 2)
If rtn = 0 Then rtn = GdipSetSmoothingMode(hGrap, SmoothingModeAntiAlias)
If rtn = 0 Then rtn = GdipSetPenDashStyle(hPen, DashStyleDash)
If rtn = 0 Then rtn = GdipDrawEllipse(hGrap, hPen, 0, 0, sizeSQ - 1!, sizeSQ - 1!)
If hPen Then Call GdipDeletePen(hPen): hPen = 0
Rem バウンディングボックスの描画
If OptReal.Value Then
If rtn = 0 Then rtn = GdipTranslateWorldTransform(hGrap, -ImgWidth / 2!, -ImgHeight / 2!, MatrixOrderAppend)
If rtn = 0 Then rtn = GdipRotateWorldTransform(hGrap, Angle, MatrixOrderAppend)
If rtn = 0 Then rtn = GdipTranslateWorldTransform(hGrap, sizeSQ / 2!, sizeSQ / 2!, MatrixOrderAppend)
Else
If rtn = 0 Then rtn = GdipTranslateWorldTransform(hGrap, -Int(ImgWidth / 2), -Int(ImgHeight / 2), MatrixOrderAppend)
If rtn = 0 Then rtn = GdipRotateWorldTransform(hGrap, Angle, MatrixOrderAppend)
If rtn = 0 Then rtn = GdipTranslateWorldTransform(hGrap, Int(sizeSQ / 2), Int(sizeSQ / 2), MatrixOrderAppend)
End If
If rtn = 0 Then rtn = GdipCreateHatchBrush(HatchStyleSmallCheckerBoard, IIf(BkColor1 > &HFF999999, &HFFFF0000, &HBFFF0000), IIf(BkColor1 > &HFF999999, &HBFFFFFBF, &HFFFFFFBF), hBrush)
If rtn = 0 Then rtn = GdipCreatePen2(hBrush, 1, UnitPixel, hPen)
If szMod(Angle, 90#) <> 0 Then
If rtn = 0 Then rtn = GdipSetSmoothingMode(hGrap, SmoothingModeAntiAlias)
End If
If rtn = 0 Then rtn = GdipDrawRectangleI(hGrap, hPen, 0, 0, ImgWidth - 1, ImgHeight - 1)
If rtn = 0 Then rtn = GdipDrawLine(hGrap, hPen, (ImgWidth - 1) / 2, 0, (ImgWidth - 1) / 2, ImgHeight - 1)
If rtn = 0 Then rtn = GdipDrawLine(hGrap, hPen, 0, (ImgHeight - 1) / 2, ImgWidth - 1, (ImgHeight - 1) / 2)
If hPen Then Call GdipDeletePen(hPen): hPen = 0
If hBrush Then Call GdipDeleteBrush(hBrush): hBrush = 0
Rem クロップドサイズボックスの描画
Dim pos As Single
If rtn = 0 Then rtn = GdipCreateHatchBrush(HatchStyleSmallCheckerBoard, &HFFFF0000, 0, hBrush)
If rtn = 0 Then rtn = GdipCreatePen2(hBrush, 1, UnitPixel, hPen)
If SrcLeft Then
pos = (ImgWidth - 1) * SrcLeft / orgWidth
If rtn = 0 Then rtn = GdipDrawLine(hGrap, hPen, pos, 0, pos, ImgHeight - 1)
End If
If SrcRight Then
pos = (ImgWidth - 1) * (orgWidth - SrcRight) / orgWidth
If rtn = 0 Then rtn = GdipDrawLine(hGrap, hPen, pos, 0, pos, ImgHeight - 1)
End If
If SrcTop Then
pos = (ImgHeight - 1) * SrcTop / orgHeight
If rtn = 0 Then rtn = GdipDrawLine(hGrap, hPen, 0, pos, ImgWidth - 1, pos)
End If
If SrcBottom Then
pos = (ImgHeight - 1) * (orgHeight - SrcBottom) / orgHeight
If rtn = 0 Then rtn = GdipDrawLine(hGrap, hPen, 0, pos, ImgWidth - 1, pos)
End If
If hPen Then Call GdipDeletePen(hPen): hPen = 0
If hBrush Then Call GdipDeleteBrush(hBrush): hBrush = 0
End If
bkINT.Value = SysColor2RGB(Img1.BackColor)
LSet bkOLE = bkINT
bkARGB.Red = bkOLE.Red
bkARGB.Green = bkOLE.Green
bkARGB.Blue = bkOLE.Blue
LSet bkINT = bkARGB
If GdipCreateHBITMAPFromBitmap(hBmp, HBITMAP, bkINT.Value) = 0 Then
Img1.Picture = CreatePictureByhBmp(HBITMAP)
Me.Repaint
End If
If hGrap Then Call GdipDeleteGraphics(hGrap)
If hBmp Then Call GdipDisposeImage(hBmp)
End Sub
Private Function szMod(ByVal Number As Double, ByVal Divisor As Double) As Double
szMod = Number - Divisor * Int(CDec(Number / Divisor))
End Function
Private Function CreateColorKeyGradient(ARGB1 As typeARGB, ARGB2 As typeARGB) As IPictureDisp
Dim hGpBmp As LongPtr, rtn As Long, hGrap As LongPtr, hBrus As LongPtr, hPen As LongPtr, HBITMAP As LongPtr
Dim pt1 As POINTL, pt2 As POINTL
Dim Int1 As typeINT32, Int2 As typeINT32
pt2.x = &HFF&
LSet Int1 = ARGB1
LSet Int2 = ARGB2
If rtn = 0 Then rtn = GdipCreateBitmapFromScan0(&H100, 1, 0&, PixelFormat32bppARGB, ByVal 0&, hGpBmp)
If rtn = 0 Then rtn = GdipGetImageGraphicsContext(hGpBmp, hGrap)
If rtn = 0 Then rtn = GdipCreateLineBrushI(pt1, pt2, Int1.Value, Int2.Value, WrapModeTile, hBrus)
If rtn = 0 Then rtn = GdipCreatePen2(hBrus, 1, UnitPixel, hPen)
If rtn = 0 Then rtn = GdipDrawLineI(hGrap, hPen, 0, 0, &HFF&, 0)
If hPen Then Call GdipDeletePen(hPen)
If hBrus Then Call GdipDeleteBrush(hBrus)
If hGrap Then Call GdipDeleteGraphics(hGrap)
If GdipCreateHBITMAPFromBitmap(hGpBmp, HBITMAP, 0) = 0 Then Set CreateColorKeyGradient = CreatePictureByhBmp(HBITMAP)
If hGpBmp Then Call GdipDisposeImage(hGpBmp)
End Function
Private Function CreateCheckerBoardTextureBrush(ByVal clSize As Long, color1 As typeARGB, color2 As typeARGB) As LongPtr
Dim px() As typeARGB, r As Long, c As Long, hTxImg As LongPtr, hTxBrush As LongPtr
If clSize < 1 Then clSize = 1
ReDim px(1 To clSize * 2, 1 To clSize * 2)
For r = 1 To clSize * 2
For c = 1 To clSize * 2
If r <= clSize Xor c <= clSize Then
px(c, r) = color1
Else
px(c, r) = color2
End If
Next
Next
hTxImg = CreateFromBits(px)
If hTxImg Then
Call GdipCreateTexture(hTxImg, WrapModeTile, hTxBrush)
CreateCheckerBoardTextureBrush = hTxBrush
Call GdipDisposeImage(hTxImg)
End If
End Function
Private Function CreateCheckerPic(color1 As Long, color2 As Long, pxSize As Long, Width As Long, Height As Long) As IPictureDisp
Dim c1 As typeARGB, c2 As typeARGB, c32 As typeINT32
c32.Value = color1
LSet c1 = c32
c32.Value = color2
LSet c2 = c32
Dim hGpBmp As LongPtr, hGrap As LongPtr, rtn As Long, hBrush As LongPtr, HBITMAP As LongPtr
rtn = GdipCreateBitmapFromScan0(pxSize * Width, pxSize * Height, 0, PixelFormat32bppARGB, ByVal 0, hGpBmp)
If rtn = 0 Then rtn = GdipGetImageGraphicsContext(hGpBmp, hGrap)
hBrush = CreateCheckerBoardTextureBrush(pxSize, c1, c2)
If rtn = 0 Then rtn = GdipFillRectangleI(hGrap, hBrush, 0, 0, pxSize * Width, pxSize * Height)
If hBrush Then Call GdipDeleteBrush(hBrush)
If hGrap Then Call GdipDeleteGraphics(hGrap)
If GdipCreateHBITMAPFromBitmap(hGpBmp, HBITMAP, 0) = 0 Then Set CreateCheckerPic = CreatePictureByhBmp(HBITMAP)
If hGpBmp Then Call GdipDisposeImage(hGpBmp)
End Function
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Sub Btn1_Click() 'Open
If Not LoadImageToMeFromFile Then Exit Sub
If hImg = 0 Then Exit Sub
Angle = 0
Call ResetImgSize
Call RotateImage
Call cngSizeMode(True)
End Sub
Private Sub Btn2_Click() 'Paste from Clipboard
If Not LoadImageToMeFromClipboard Then Exit Sub
If hImg = 0 Then Exit Sub
Angle = 0
Call ResetImgSize
Call RotateImage
Call cngSizeMode(True)
End Sub
Private Sub Btn3_Click() '+90deg
If hImg = 0 Then Exit Sub
If GdipImageRotateFlip(hImg, Rotate90FlipNone) Then Exit Sub
Dim swpW As Long, swpH As Long
swpW = orgHeight: swpH = orgWidth
orgHeight = swpH: orgWidth = swpW
swpW = ImgHeight: swpH = ImgWidth
ImgHeight = swpH: ImgWidth = swpW
TextSrcWidth.Text = orgWidth
TextSrcHeight.Text = orgHeight
swpW = LockedHeight: swpH = LockedWidth
LockedHeight = swpH: LockedWidth = swpW
Dim swpT As Long, swpL As Long, swpB As Long, swpR As Long
swpT = SrcLeft
swpL = SrcBottom
swpB = SrcRight
swpR = SrcTop
If ChkBxLockRect.Value Then
SpinCropLeft.Max = LockedWidth
SpinCropRight.Max = LockedWidth
SpinCropTop.Max = LockedHeight
SpinCropBottom.Max = LockedHeight
Else
SpinCropLeft.Max = orgWidth
SpinCropRight.Max = orgWidth
SpinCropTop.Max = orgHeight
SpinCropBottom.Max = orgHeight
End If
SrcTop = swpT
SrcLeft = swpL
SrcBottom = swpB
SrcRight = swpR
Call RotateImage
End Sub
Private Sub Btn4_Click() 'Horizontal Flip
If hImg = 0 Then Exit Sub
If GdipImageRotateFlip(hImg, RotateNoneFlipX) Then Exit Sub
Angle = -Angle
Dim swpL As Long, swpR As Long
swpL = SrcRight
swpR = SrcLeft
SrcLeft = swpL
SrcRight = swpR
Call RotateImage
End Sub
Private Sub Btn5_Click() 'Vertical Flip
If hImg = 0 Then Exit Sub
If GdipImageRotateFlip(hImg, RotateNoneFlipY) Then Exit Sub
Angle = -Angle
Dim swpT As Long, swpB As Long
swpT = SrcBottom
swpB = SrcTop
SrcTop = swpT
SrcBottom = swpB
Call RotateImage
End Sub
Private Sub Btn6_Click() 'Copy to Clipboard
If hTmp = 0 Then Exit Sub
Dim hNew As LongPtr
hNew = TrimTransparentPixels(hTmp)
Call CopyPngtoClipboard(hNew)
Call GdipDisposeImage(hNew)
End Sub
Private Sub Btn7_Click() 'Save to File
If hTmp = 0 Then Exit Sub
Dim savePath As String, fidx As Long
Select Case UCase$(Right$(pathImg, 3))
Case "PNG": fidx = 2
Case "JPG": fidx = 3
Case "TIF": fidx = 4
Case "GIF": fidx = 5
Case "BMP": fidx = 6
Case Else: fidx = 1
End Select
savePath = NumberedFilename(pathImg, , Format$(Now(), "_yyyymmdd_hhnnss"))
savePath = Application.GetSaveAsFilename(savePath, "サポートするファイル形式,*.png;*.jpg;*.tif;*.gif;*.bmp,PNG 形式,*.png,JPEG 形式,*.jpg,TIF 形式,*.tif,GIF 形式,*.gif,Windows ビットマップ,*.bmp,すべてのファイル,*.*", fidx)
If savePath = "False" Then Exit Sub
Dim hNew As LongPtr
hNew = TrimTransparentPixels(hTmp)
Call SaveToFile(hNew, NumberedFilename(savePath))
Call GdipDisposeImage(hNew)
End Sub
Private Sub BtnHighColor_Click()
EventOff = True
SpinHighR.Value = TextPointR.Text
TextHighR.Text = TextPointR.Text
SpinHighG.Value = TextPointG.Text
TextHighG.Text = TextPointG.Text
SpinHighB.Value = TextPointB.Text
TextHighB.Text = TextPointB.Text
If SpinLowR.Value > SpinHighR.Value Then
SpinLowR.Value = TextPointR.Text
TextLowR.Text = TextPointR.Text
End If
If SpinLowG.Value > SpinHighG.Value Then
SpinLowG.Value = TextPointG.Text
TextLowG.Text = TextPointG.Text
End If
If SpinLowB.Value > SpinHighB.Value Then
SpinLowB.Value = TextPointB.Text
TextLowB.Text = TextPointB.Text
End If
EventOff = False
Call UpdateColorKeySample
If ChkBxColorKey.Value Then Call RotateImage
End Sub
Private Sub BtnLowColor_Click()
EventOff = True
SpinLowR.Value = TextPointR.Text
TextLowR.Text = TextPointR.Text
SpinLowG.Value = TextPointG.Text
TextLowG.Text = TextPointG.Text
SpinLowB.Value = TextPointB.Text
TextLowB.Text = TextPointB.Text
If SpinHighR.Value < SpinLowR.Value Then
SpinHighR.Value = TextPointR.Text
TextHighR.Text = TextPointR.Text
End If
If SpinHighG.Value < SpinLowG.Value Then
SpinHighG.Value = TextPointG.Text
TextHighG.Text = TextPointG.Text
End If
If SpinHighB.Value < SpinLowB.Value Then
SpinHighB.Value = TextPointB.Text
TextHighB.Text = TextPointB.Text
End If
EventOff = False
Call UpdateColorKeySample
If ChkBxColorKey.Value Then Call RotateImage
End Sub
Private Property Get IsGetPxRunning() As Boolean
IsGetPxRunning = IsLooping
End Property
Private Property Let IsGetPxRunning(newValue As Boolean)
If IsLooping = newValue Then Exit Property
IsLooping = newValue
If IsLooping Then
LabelPointColorMsg.Visible = True
Call GetPointPixelColor
Else
LabelPickedColor.BackColor = LabelPointColor.BackColor
BtnPointColor.Value = False
LabelPointColorMsg.Visible = False
End If
End Property
Private Sub GetPointPixelColor()
Dim hDC As LongPtr, pt As POINTAPI, c As typeCOLORREF, i As typeINT32
Application.EnableCancelKey = xlDisabled
hDC = GetDC(0&)
Do While IsLooping
Call GetCursorPos(pt)
i.Value = GetPixel(hDC, pt.x, pt.y)
LSet c = i
LabelPointColor.BackColor = i.Value
TextPointR.Text = c.Red
TextPointG.Text = c.Green
TextPointB.Text = c.Blue
If GetAsyncKeyState(vbKeyEscape) Then IsGetPxRunning = False
DoEvents
Sleep 50
Loop
Call ReleaseDC(0, hDC)
Application.EnableCancelKey = xlInterrupt
End Sub
Private Sub BtnPointColor_Click()
IsGetPxRunning = BtnPointColor.Value
' Dim px() As typeARGB
' If hImg Then
' Call GdipDisposeImage(hImg)
' hImg = 0
' End If
'' Dim hBtnPic As LongPtr
'' Call GdipCreateBitmapFromHBITMAP(BtnPointColor.Picture.handle, BtnPointColor.Picture.hPal, hBtnPic)
'' px = GetBits(hBtnPic)
' px = GetBitsFromHBITMAP(BtnPointColor.Picture.handle)
' hImg = CreateFromBits(px)
' If hImg = 0 Then Exit Sub
' Angle = 0
' Call ResetImgSize
' Call RotateImage
' Call cngSizeMode(True)
End Sub
Private Sub BtnBkColor_Click()
If BkColor1 = &HFFFFFFFF Then
BkColor1 = &HFFCCCCCC
BkColor2 = &HFF999999
ElseIf BkColor1 = &HFFCCCCCC Then
BkColor1 = &HFF999999
BkColor2 = &HFF666666
ElseIf BkColor1 = &HFF999999 Then
BkColor1 = &HFF666666
BkColor2 = &HFF333333
ElseIf BkColor1 = &HFF666666 Then
BkColor1 = &HFFFFFFFF
BkColor2 = &HFFCCCCCC
End If
Set BtnBkColor.Picture = CreateCheckerPic(BkColor1, BkColor2, 5, 3, 3)
If hImg Then Call UpdatePreviewPicture
End Sub
Private Sub ChkBxPOM_Click() 'PixelOffsetMode
If hImg = 0 Then Exit Sub
Call RotateImage
End Sub
Private Sub ComboInterpolationMode_Change()
If hImg = 0 Then Exit Sub
Call RotateImage
End Sub
Private Sub Img1_Click()
Call cngSizeMode
End Sub
Private Sub Img1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If Img1.Width = 0 Then Exit Sub
If Img1.Height = 0 Then Exit Sub
If x < 0 Then x = 0
If y < 0 Then y = 0
If x > Img1.Width Then x = Img1.Width
If y > Img1.Height Then y = Img1.Height
ImgX = x / Img1.Width
ImgY = y / Img1.Height
End Sub
Private Sub cngSizeMode(Optional NoChange As Boolean)
Dim sm As fmPictureSizeMode
Dim w As Single, h As Single, sizeSQ As Long
sm = Img1.PictureSizeMode
If NoChange Then
sizeSQ = CLng(Sqr(ImgWidth ^ 2# + ImgHeight ^ 2#))
w = Px2PtX(sizeSQ + 2)
h = Px2PtY(sizeSQ + 2)
If sm = fmPictureSizeModeClip Then
If Frm1.ScrollWidth - Frm1.InsideWidth Then ImgX = Frm1.ScrollLeft / (Frm1.ScrollWidth - Frm1.InsideWidth)
If Frm1.ScrollHeight - Frm1.InsideHeight Then ImgY = Frm1.ScrollTop / (Frm1.ScrollHeight - Frm1.InsideHeight)
End If
Else
If sm = fmPictureSizeModeClip Then
sm = fmPictureSizeModeZoom
Else
sm = fmPictureSizeModeClip
sizeSQ = CLng(Sqr(ImgWidth ^ 2# + ImgHeight ^ 2#))
w = Px2PtX(sizeSQ + 2)
h = Px2PtY(sizeSQ + 2)
End If
End If
If w < Frm1.Width - sbBtnWidth Then w = Frm1.Width - sbBtnWidth
If h < Frm1.Height - sbBtnHeight Then h = Frm1.Height - sbBtnHeight
Img1.Width = w
Img1.Height = h
Img1.PictureSizeMode = sm
EventOff = True
Frm1.ScrollLeft = 0
Frm1.ScrollTop = 0
Frm1.ScrollWidth = w
Frm1.ScrollHeight = h
EventOff = False
If sm = fmPictureSizeModeClip Then
Dim Lmt As Single
' If ImgWidth > ImgHeight Then '当モジュールでは正方形描画だけなので邪魔(ImgWidthとImgHeightの意味があっちのと違う)
' Lmt = ((ImgWidth - ImgHeight) / 2) / ImgHeight
' If ImgY < Lmt Then ImgY = 0
' If ImgY > 1! - Lmt Then ImgY = 1!
' End If
' If ImgHeight > ImgWidth Then
' Lmt = ((ImgHeight - ImgWidth) / 2) / ImgWidth
' If ImgX < Lmt Then ImgX = 0
' If ImgX > 1! - Lmt Then ImgX = 1!
' End If
Lmt = (Frm1.Height / 2) / h
If ImgY < Lmt Then ImgY = 0
If ImgY > 1! - Lmt Then ImgY = 1!
Lmt = (Frm1.Width / 2) / w
If ImgX < Lmt Then ImgX = 0
If ImgX > 1! - Lmt Then ImgX = 1!
EventOff = True
Frm1.ScrollLeft = (w - Frm1.InsideWidth) * ImgX
Frm1.ScrollTop = (h - Frm1.InsideHeight) * ImgY
EventOff = False
End If
Me.Repaint
End Sub
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Property Get Angle() As Single
Angle = sAngle
End Property
Private Property Let Angle(ByVal newValue As Single)
If newValue = sAngle Then Exit Property
sAngle = newValue - 360! * Fix(newValue / 360!)
EventOff = True
SBar1.Value = sAngle * 100
SpinAngle.Value = SBar1.Value
EventOff = False
TextAngle.Text = Format$(sAngle, "0.00")
End Property
Private Sub SBar1_Change()
If EventOff Then Exit Sub
Angle = SBar1.Value / 100!
Call RotateImage
End Sub
Private Sub SBar1_Scroll()
If EventOff Then Exit Sub
Angle = SBar1.Value / 100!
Call RotateImage
End Sub
Private Sub SpinAngle_Change()
If EventOff Then Exit Sub
Angle = SpinAngle.Value / 100!
Call RotateImage
End Sub
Private Sub TextAngle_DropButtonClick()
Angle = 0
Call RotateImage
End Sub
Private Sub TextAngle_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim v As Long
If Shift = 1 Then v = 10 Else v = 1
Select Case KeyCode.Value
Case vbKeyF4, vbKeyTab
Exit Sub
Case vbKeyUp
If SBar1.Value + v <= SBar1.Max Then SBar1.Value = SBar1.Value + v
Case vbKeyDown
If SBar1.Value - v >= SBar1.Min Then SBar1.Value = SBar1.Value - v
End Select
If Shift = 4 Then Exit Sub
KeyCode.Value = 0
End Sub
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Property Get SrcTop() As Long
SrcTop = SpinCropTop.Value
End Property
Private Property Let SrcTop(ByVal newValue As Long)
If newValue < SpinCropTop.Min Then newValue = SpinCropTop.Min
If newValue > SpinCropTop.Max Then newValue = SpinCropTop.Max
EventOff = True
SpinCropTop.Value = newValue
TextCropTop.Text = newValue
If ChkBxLockRect.Value Then
SpinCropBottom.Value = LockedHeight - newValue
TextCropBottom.Text = SpinCropBottom.Value
End If
TextCropHeight.Text = orgHeight - SrcBottom - newValue
EventOff = False
End Property
Private Sub SpinCropTop_Change()
If EventOff Then Exit Sub
SrcTop = SpinCropTop.Value
Call RotateImage
End Sub
Private Sub TextCropTop_Change()
If EventOff Then Exit Sub
Dim v As Long
v = TextCropTop.Value
If v > SpinCropTop.Max Then v = SpinCropTop.Max
If v < SpinCropTop.Min Then v = SpinCropTop.Min
SrcTop = v
Call RotateImage
End Sub
Private Sub TextCropTop_DropButtonClick()
SrcTop = 0
Call RotateImage
End Sub
Private Sub TextCropTop_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim v As Long
If Shift = 1 Then v = 10 Else v = 1
Select Case KeyCode.Value
Case vbKeyF4, vbKeyTab
Exit Sub
Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
Exit Sub
Case vbKeyUp
If SpinCropTop.Value - v >= SpinCropTop.Min Then SpinCropTop.Value = SpinCropTop.Value - v
Case vbKeyDown
If SpinCropTop.Value + v <= SpinCropTop.Max Then SpinCropTop.Value = SpinCropTop.Value + v
End Select
If Shift = 4 Then Exit Sub
KeyCode.Value = 0
End Sub
Private Sub TextCropTop_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii.Value < vbKey0 Or KeyAscii.Value > vbKey9 Then KeyAscii.Value = 0
End Sub
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Property Get SrcLeft() As Long
SrcLeft = SpinCropLeft.Value
End Property
Private Property Let SrcLeft(ByVal newValue As Long)
If newValue < SpinCropLeft.Min Then newValue = SpinCropLeft.Min
If newValue > SpinCropLeft.Max Then newValue = SpinCropLeft.Max
EventOff = True
SpinCropLeft.Value = newValue
TextCropLeft.Text = newValue
If ChkBxLockRect.Value Then
SpinCropRight.Value = LockedWidth - newValue
TextCropRight.Text = SpinCropRight.Value
End If
TextCropWidth.Text = orgWidth - SrcRight - newValue
EventOff = False
End Property
Private Sub SpinCropLeft_Change()
If EventOff Then Exit Sub
SrcLeft = SpinCropLeft.Value
Call RotateImage
End Sub
Private Sub TextCropLeft_Change()
If EventOff Then Exit Sub
Dim v As Long
v = TextCropLeft.Value
If v > SpinCropLeft.Max Then v = SpinCropLeft.Max
If v < SpinCropLeft.Min Then v = SpinCropLeft.Min
SrcLeft = v
Call RotateImage
End Sub
Private Sub TextCropLeft_DropButtonClick()
SrcLeft = 0
Call RotateImage
End Sub
Private Sub TextCropLeft_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim v As Long
If Shift = 1 Then v = 10 Else v = 1
Select Case KeyCode.Value
Case vbKeyF4, vbKeyTab
Exit Sub
Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
Exit Sub
Case vbKeyUp
If SpinCropLeft.Value + v <= SpinCropLeft.Max Then SpinCropLeft.Value = SpinCropLeft.Value + v
Case vbKeyDown
If SpinCropLeft.Value - v >= SpinCropLeft.Min Then SpinCropLeft.Value = SpinCropLeft.Value - v
End Select
If Shift = 4 Then Exit Sub
KeyCode.Value = 0
End Sub
Private Sub TextCropLeft_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii.Value < vbKey0 Or KeyAscii.Value > vbKey9 Then KeyAscii.Value = 0
End Sub
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Property Get SrcBottom() As Long
SrcBottom = SpinCropBottom.Value
End Property
Private Property Let SrcBottom(ByVal newValue As Long)
If newValue < SpinCropBottom.Min Then newValue = SpinCropBottom.Min
If newValue > SpinCropBottom.Max Then newValue = SpinCropBottom.Max
EventOff = True
SpinCropBottom.Value = newValue
TextCropBottom.Text = newValue
If ChkBxLockRect.Value Then
SpinCropTop.Value = LockedHeight - newValue
TextCropTop.Text = SpinCropTop.Value
End If
TextCropHeight.Text = orgHeight - newValue - SrcTop
EventOff = False
End Property
Private Sub SpinCropBottom_Change()
If EventOff Then Exit Sub
SrcBottom = SpinCropBottom.Value
Call RotateImage
End Sub
Private Sub TextCropBottom_Change()
If EventOff Then Exit Sub
Dim v As Long
v = TextCropBottom.Value
If v > SpinCropBottom.Max Then v = SpinCropBottom.Max
If v < SpinCropBottom.Min Then v = SpinCropBottom.Min
SrcBottom = v
Call RotateImage
End Sub
Private Sub TextCropBottom_DropButtonClick()
SrcBottom = 0
Call RotateImage
End Sub
Private Sub TextCropBottom_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim v As Long
If Shift = 1 Then v = 10 Else v = 1
Select Case KeyCode.Value
Case vbKeyF4, vbKeyTab
Exit Sub
Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
Exit Sub
Case vbKeyUp
If SpinCropBottom.Value + v <= SpinCropBottom.Max Then SpinCropBottom.Value = SpinCropBottom.Value + v
Case vbKeyDown
If SpinCropBottom.Value - v >= SpinCropBottom.Min Then SpinCropBottom.Value = SpinCropBottom.Value - v
End Select
If Shift = 4 Then Exit Sub
KeyCode.Value = 0
End Sub
Private Sub TextCropBottom_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii.Value < vbKey0 Or KeyAscii.Value > vbKey9 Then KeyAscii.Value = 0
End Sub
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Property Get SrcRight() As Long
SrcRight = SpinCropRight.Value
End Property
Private Property Let SrcRight(ByVal newValue As Long)
If newValue < SpinCropRight.Min Then newValue = SpinCropRight.Min
If newValue > SpinCropRight.Max Then newValue = SpinCropRight.Max
EventOff = True
SpinCropRight.Value = newValue
TextCropRight.Text = newValue
If ChkBxLockRect.Value Then
SpinCropLeft.Value = LockedWidth - newValue
TextCropLeft.Text = SpinCropLeft.Value
End If
TextCropWidth.Text = orgWidth - newValue - SrcLeft
EventOff = False
End Property
Private Sub SpinCropRight_Change()
If EventOff Then Exit Sub
SrcRight = SpinCropRight.Value
Call RotateImage
End Sub
Private Sub TextCropRight_Change()
If EventOff Then Exit Sub
Dim v As Long
v = TextCropRight.Value
If v > SpinCropRight.Max Then v = SpinCropRight.Max
If v < SpinCropRight.Min Then v = SpinCropRight.Min
SrcRight = v
Call RotateImage
End Sub
Private Sub TextCropRight_DropButtonClick()
SrcRight = 0
Call RotateImage
End Sub
Private Sub TextCropRight_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim v As Long
If Shift = 1 Then v = 10 Else v = 1
Select Case KeyCode.Value
Case vbKeyF4, vbKeyTab
Exit Sub
Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
Exit Sub
Case vbKeyUp
If SpinCropRight.Value + v <= SpinCropRight.Max Then SpinCropRight.Value = SpinCropRight.Value + v
Case vbKeyDown
If SpinCropRight.Value - v >= SpinCropRight.Min Then SpinCropRight.Value = SpinCropRight.Value - v
End Select
If Shift = 4 Then Exit Sub
KeyCode.Value = 0
End Sub
Private Sub TextCropRight_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii.Value < vbKey0 Or KeyAscii.Value > vbKey9 Then KeyAscii.Value = 0
End Sub
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Property Get ColorKeyHighR() As Long
ColorKeyHighR = SpinHighR.Value
End Property
Private Property Let ColorKeyHighR(ByVal newValue As Long)
If newValue < SpinHighR.Min Then newValue = SpinHighR.Min
If newValue > SpinHighR.Max Then newValue = SpinHighR.Max
EventOff = True
SpinHighR.Value = newValue
TextHighR.Text = newValue
If newValue < ColorKeyLowR Then
SpinLowR.Value = newValue
TextLowR.Text = newValue
End If
If ChkBxRGBSync.Value Then
SpinHighG.Value = newValue
TextHighG.Text = newValue
If newValue < ColorKeyLowG Then
SpinLowG.Value = newValue
TextLowG.Text = newValue
End If
SpinHighB.Value = newValue
TextHighB.Text = newValue
If newValue < ColorKeyLowB Then
SpinLowB.Value = newValue
TextLowB.Text = newValue
End If
End If
EventOff = False
Call UpdateColorKeySample
End Property
Private Sub SpinHighR_Change()
If EventOff Then Exit Sub
ColorKeyHighR = SpinHighR.Value
Call RotateImage
End Sub
Private Sub TextHighR_Change()
If EventOff Then Exit Sub
Dim v As Long
v = TextHighR.Value
If v > SpinHighR.Max Then v = SpinHighR.Max
If v < SpinHighR.Min Then v = SpinHighR.Min
ColorKeyHighR = v
Call RotateImage
End Sub
Private Sub TextHighR_DropButtonClick()
ColorKeyHighR = 255
Call RotateImage
End Sub
Private Sub TextHighR_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim v As Long
If Shift = 1 Then v = 10 Else v = 1
Select Case KeyCode.Value
Case vbKeyF4, vbKeyTab
Exit Sub
Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
Exit Sub
Case vbKeyUp
If SpinHighR.Value + v <= SpinHighR.Max Then SpinHighR.Value = SpinHighR.Value + v
Case vbKeyDown
If SpinHighR.Value - v >= SpinHighR.Min Then SpinHighR.Value = SpinHighR.Value - v
End Select
If Shift = 4 Then Exit Sub
KeyCode.Value = 0
End Sub
Private Sub TextHighR_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii.Value < vbKey0 Or KeyAscii.Value > vbKey9 Then KeyAscii.Value = 0
End Sub
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Property Get ColorKeyHighG() As Long
ColorKeyHighG = SpinHighG.Value
End Property
Private Property Let ColorKeyHighG(ByVal newValue As Long)
If newValue < SpinHighG.Min Then newValue = SpinHighG.Min
If newValue > SpinHighG.Max Then newValue = SpinHighG.Max
EventOff = True
SpinHighG.Value = newValue
TextHighG.Text = newValue
If newValue < ColorKeyLowG Then
SpinLowG.Value = newValue
TextLowG.Text = newValue
End If
If ChkBxRGBSync.Value Then
SpinHighR.Value = newValue
TextHighR.Text = newValue
If newValue < ColorKeyLowR Then
SpinLowR.Value = newValue
TextLowR.Text = newValue
End If
SpinHighB.Value = newValue
TextHighB.Text = newValue
If newValue < ColorKeyLowB Then
SpinLowB.Value = newValue
TextLowB.Text = newValue
End If
End If
EventOff = False
Call UpdateColorKeySample
End Property
Private Sub SpinHighG_Change()
If EventOff Then Exit Sub
ColorKeyHighG = SpinHighG.Value
Call RotateImage
End Sub
Private Sub TextHighG_Change()
If EventOff Then Exit Sub
Dim v As Long
v = TextHighG.Value
If v > SpinHighG.Max Then v = SpinHighG.Max
If v < SpinHighG.Min Then v = SpinHighG.Min
ColorKeyHighG = v
Call RotateImage
End Sub
Private Sub TextHighG_DropButtonClick()
ColorKeyHighG = 255
Call RotateImage
End Sub
Private Sub TextHighG_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim v As Long
If Shift = 1 Then v = 10 Else v = 1
Select Case KeyCode.Value
Case vbKeyF4, vbKeyTab
Exit Sub
Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
Exit Sub
Case vbKeyUp
If SpinHighG.Value + v <= SpinHighG.Max Then SpinHighG.Value = SpinHighG.Value + v
Case vbKeyDown
If SpinHighG.Value - v >= SpinHighG.Min Then SpinHighG.Value = SpinHighG.Value - v
End Select
If Shift = 4 Then Exit Sub
KeyCode.Value = 0
End Sub
Private Sub TextHighG_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii.Value < vbKey0 Or KeyAscii.Value > vbKey9 Then KeyAscii.Value = 0
End Sub
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Property Get ColorKeyHighB() As Long
ColorKeyHighB = SpinHighB.Value
End Property
Private Property Let ColorKeyHighB(ByVal newValue As Long)
If newValue < SpinHighB.Min Then newValue = SpinHighB.Min
If newValue > SpinHighB.Max Then newValue = SpinHighB.Max
EventOff = True
SpinHighB.Value = newValue
TextHighB.Text = newValue
If newValue < ColorKeyLowB Then
SpinLowB.Value = newValue
TextLowB.Text = newValue
End If
If ChkBxRGBSync.Value Then
SpinHighR.Value = newValue
TextHighR.Text = newValue
If newValue < ColorKeyLowR Then
SpinLowR.Value = newValue
TextLowR.Text = newValue
End If
SpinHighG.Value = newValue
TextHighG.Text = newValue
If newValue < ColorKeyLowG Then
SpinLowG.Value = newValue
TextLowG.Text = newValue
End If
End If
EventOff = False
Call UpdateColorKeySample
End Property
Private Sub SpinHighB_Change()
If EventOff Then Exit Sub
ColorKeyHighB = SpinHighB.Value
Call RotateImage
End Sub
Private Sub TextHighB_Change()
If EventOff Then Exit Sub
Dim v As Long
v = TextHighB.Value
If v > SpinHighB.Max Then v = SpinHighB.Max
If v < SpinHighB.Min Then v = SpinHighB.Min
ColorKeyHighB = v
Call RotateImage
End Sub
Private Sub TextHighB_DropButtonClick()
ColorKeyHighB = 255
Call RotateImage
End Sub
Private Sub TextHighB_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim v As Long
If Shift = 1 Then v = 10 Else v = 1
Select Case KeyCode.Value
Case vbKeyF4, vbKeyTab
Exit Sub
Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
Exit Sub
Case vbKeyUp
If SpinHighB.Value + v <= SpinHighB.Max Then SpinHighB.Value = SpinHighB.Value + v
Case vbKeyDown
If SpinHighB.Value - v >= SpinHighB.Min Then SpinHighB.Value = SpinHighB.Value - v
End Select
If Shift = 4 Then Exit Sub
KeyCode.Value = 0
End Sub
Private Sub TextHighB_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii.Value < vbKey0 Or KeyAscii.Value > vbKey9 Then KeyAscii.Value = 0
End Sub
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Property Get ColorKeyLowR() As Long
ColorKeyLowR = SpinLowR.Value
End Property
Private Property Let ColorKeyLowR(ByVal newValue As Long)
If newValue < SpinLowR.Min Then newValue = SpinLowR.Min
If newValue > SpinLowR.Max Then newValue = SpinLowR.Max
EventOff = True
SpinLowR.Value = newValue
TextLowR.Text = newValue
If newValue > ColorKeyHighR Then
SpinHighR.Value = newValue
TextHighR.Text = newValue
End If
If ChkBxRGBSync.Value Then
SpinLowG.Value = newValue
TextLowG.Text = newValue
If newValue > ColorKeyHighG Then
SpinHighG.Value = newValue
TextHighG.Text = newValue
End If
SpinLowB.Value = newValue
TextLowB.Text = newValue
If newValue > ColorKeyHighB Then
SpinHighB.Value = newValue
TextHighB.Text = newValue
End If
End If
EventOff = False
Call UpdateColorKeySample
End Property
Private Sub SpinLowR_Change()
If EventOff Then Exit Sub
ColorKeyLowR = SpinLowR.Value
Call RotateImage
End Sub
Private Sub TextLowR_Change()
If EventOff Then Exit Sub
Dim v As Long
v = TextLowR.Value
If v > SpinLowR.Max Then v = SpinLowR.Max
If v < SpinLowR.Min Then v = SpinLowR.Min
ColorKeyLowR = v
Call RotateImage
End Sub
Private Sub TextLowR_DropButtonClick()
ColorKeyLowR = 255
Call RotateImage
End Sub
Private Sub TextLowR_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim v As Long
If Shift = 1 Then v = 10 Else v = 1
Select Case KeyCode.Value
Case vbKeyF4, vbKeyTab
Exit Sub
Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
Exit Sub
Case vbKeyUp
If SpinLowR.Value + v <= SpinLowR.Max Then SpinLowR.Value = SpinLowR.Value + v
Case vbKeyDown
If SpinLowR.Value - v >= SpinLowR.Min Then SpinLowR.Value = SpinLowR.Value - v
End Select
If Shift = 4 Then Exit Sub
KeyCode.Value = 0
End Sub
Private Sub TextLowR_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii.Value < vbKey0 Or KeyAscii.Value > vbKey9 Then KeyAscii.Value = 0
End Sub
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Property Get ColorKeyLowG() As Long
ColorKeyLowG = SpinLowG.Value
End Property
Private Property Let ColorKeyLowG(ByVal newValue As Long)
If newValue < SpinLowG.Min Then newValue = SpinLowG.Min
If newValue > SpinLowG.Max Then newValue = SpinLowG.Max
EventOff = True
SpinLowG.Value = newValue
TextLowG.Text = newValue
If newValue > ColorKeyHighG Then
SpinHighG.Value = newValue
TextHighG.Text = newValue
End If
If ChkBxRGBSync.Value Then
SpinLowR.Value = newValue
TextLowR.Text = newValue
If newValue > ColorKeyHighR Then
SpinHighR.Value = newValue
TextHighR.Text = newValue
End If
SpinLowB.Value = newValue
TextLowB.Text = newValue
If newValue > ColorKeyHighB Then
SpinHighB.Value = newValue
TextHighB.Text = newValue
End If
End If
EventOff = False
Call UpdateColorKeySample
End Property
Private Sub SpinLowG_Change()
If EventOff Then Exit Sub
ColorKeyLowG = SpinLowG.Value
Call RotateImage
End Sub
Private Sub TextLowG_Change()
If EventOff Then Exit Sub
Dim v As Long
v = TextLowG.Value
If v > SpinLowG.Max Then v = SpinLowG.Max
If v < SpinLowG.Min Then v = SpinLowG.Min
ColorKeyLowG = v
Call RotateImage
End Sub
Private Sub TextLowG_DropButtonClick()
ColorKeyLowG = 255
Call RotateImage
End Sub
Private Sub TextLowG_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim v As Long
If Shift = 1 Then v = 10 Else v = 1
Select Case KeyCode.Value
Case vbKeyF4, vbKeyTab
Exit Sub
Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
Exit Sub
Case vbKeyUp
If SpinLowG.Value + v <= SpinLowG.Max Then SpinLowG.Value = SpinLowG.Value + v
Case vbKeyDown
If SpinLowG.Value - v >= SpinLowG.Min Then SpinLowG.Value = SpinLowG.Value - v
End Select
If Shift = 4 Then Exit Sub
KeyCode.Value = 0
End Sub
Private Sub TextLowG_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii.Value < vbKey0 Or KeyAscii.Value > vbKey9 Then KeyAscii.Value = 0
End Sub
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Property Get ColorKeyLowB() As Long
ColorKeyLowB = SpinLowB.Value
End Property
Private Property Let ColorKeyLowB(ByVal newValue As Long)
If newValue < SpinLowB.Min Then newValue = SpinLowB.Min
If newValue > SpinLowB.Max Then newValue = SpinLowB.Max
EventOff = True
SpinLowB.Value = newValue
TextLowB.Text = newValue
If newValue > ColorKeyHighB Then
SpinHighB.Value = newValue
TextHighB.Text = newValue
End If
If ChkBxRGBSync.Value Then
SpinLowR.Value = newValue
TextLowR.Text = newValue
If newValue > ColorKeyHighR Then
SpinHighR.Value = newValue
TextHighR.Text = newValue
End If
SpinLowG.Value = newValue
TextLowG.Text = newValue
If newValue > ColorKeyHighG Then
SpinHighG.Value = newValue
TextHighG.Text = newValue
End If
End If
EventOff = False
Call UpdateColorKeySample
End Property
Private Sub SpinLowB_Change()
If EventOff Then Exit Sub
ColorKeyLowB = SpinLowB.Value
Call RotateImage
End Sub
Private Sub TextLowB_Change()
If EventOff Then Exit Sub
Dim v As Long
v = TextLowB.Value
If v > SpinLowB.Max Then v = SpinLowB.Max
If v < SpinLowB.Min Then v = SpinLowB.Min
ColorKeyLowB = v
Call RotateImage
End Sub
Private Sub TextLowB_DropButtonClick()
ColorKeyLowB = 255
Call RotateImage
End Sub
Private Sub TextLowB_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim v As Long
If Shift = 1 Then v = 10 Else v = 1
Select Case KeyCode.Value
Case vbKeyF4, vbKeyTab
Exit Sub
Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
Exit Sub
Case vbKeyUp
If SpinLowB.Value + v <= SpinLowB.Max Then SpinLowB.Value = SpinLowB.Value + v
Case vbKeyDown
If SpinLowB.Value - v >= SpinLowB.Min Then SpinLowB.Value = SpinLowB.Value - v
End Select
If Shift = 4 Then Exit Sub
KeyCode.Value = 0
End Sub
Private Sub TextLowB_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii.Value < vbKey0 Or KeyAscii.Value > vbKey9 Then KeyAscii.Value = 0
End Sub
Private Sub UpdateColorKeySample()
Dim l As Long, h As Long
h = ColorKeyHighR + ColorKeyHighG * &H100& + ColorKeyHighB * &H10000
BtnHighColor.BackColor = h
l = ColorKeyLowR + ColorKeyLowG * &H100& + ColorKeyLowB * &H10000
BtnLowColor.BackColor = l
Dim ARGBHigh As typeARGB, ARGBLow As typeARGB
ARGBHigh.Red = ColorKeyHighR
ARGBHigh.Green = ColorKeyHighG
ARGBHigh.Blue = ColorKeyHighB
ARGBHigh.Alpha = &HFF&
ARGBLow.Red = ColorKeyLowR
ARGBLow.Green = ColorKeyLowG
ARGBLow.Blue = ColorKeyLowB
ARGBLow.Alpha = &HFF&
Set ImgColorKeyGradient.Picture = CreateColorKeyGradient(ARGBLow, ARGBHigh)
' Me.Repaint
End Sub
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Property Get ImgHeight() As Long
ImgHeight = SpinHeight.Value
End Property
Private Property Let ImgHeight(ByVal newValue As Long)
If newValue < SpinHeight.Min Then newValue = SpinHeight.Min
If newValue > SpinHeight.Max Then newValue = SpinHeight.Max
EventOff = True
SpinHeight.Value = newValue
TextHeight.Text = newValue
If ChkBxLAR.Value Then
SpinWidth.Value = newValue * CSng(orgWidth / orgHeight)
TextWidth.Text = SpinWidth.Value
End If
EventOff = False
End Property
Private Sub SpinHeight_Change()
If EventOff Then Exit Sub
ImgHeight = SpinHeight.Value
Call RotateImage
End Sub
Private Sub TextHeight_Change()
If EventOff Then Exit Sub
Dim v As Long
v = TextHeight.Value
If v > SpinHeight.Max Then v = SpinHeight.Max
If v < SpinHeight.Min Then v = SpinHeight.Min
ImgHeight = v
Call RotateImage
End Sub
Private Sub TextHeight_DropButtonClick()
ImgHeight = orgHeight
Call RotateImage
End Sub
Private Sub TextHeight_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim v As Long
If Shift = 1 Then v = 10 Else v = 1
Select Case KeyCode.Value
Case vbKeyF4, vbKeyTab
Exit Sub
Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
Exit Sub
Case vbKeyUp
If SpinHeight.Value + v <= SpinHeight.Max Then SpinHeight.Value = SpinHeight.Value + v
Case vbKeyDown
If SpinHeight.Value - v >= SpinHeight.Min Then SpinHeight.Value = SpinHeight.Value - v
End Select
If Shift = 4 Then Exit Sub
KeyCode.Value = 0
End Sub
Private Sub TextHeight_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii.Value < vbKey0 Or KeyAscii.Value > vbKey9 Then KeyAscii.Value = 0
End Sub
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Property Get ImgWidth() As Long
ImgWidth = SpinWidth.Value
End Property
Private Property Let ImgWidth(ByVal newValue As Long)
If newValue < SpinWidth.Min Then newValue = SpinWidth.Min
If newValue > SpinWidth.Max Then newValue = SpinWidth.Max
EventOff = True
SpinWidth.Value = newValue
TextWidth.Text = newValue
If ChkBxLAR.Value Then
SpinHeight.Value = newValue * CSng(orgHeight / orgWidth)
TextHeight.Text = SpinHeight.Value
End If
EventOff = False
End Property
Private Sub SpinWidth_Change()
If EventOff Then Exit Sub
ImgWidth = SpinWidth.Value
Call RotateImage
End Sub
Private Sub TextWidth_Change()
If EventOff Then Exit Sub
Dim v As Long
v = TextWidth.Value
If v > SpinWidth.Max Then v = SpinWidth.Max
If v < SpinWidth.Min Then v = SpinWidth.Min
ImgWidth = v
Call RotateImage
End Sub
Private Sub TextWidth_DropButtonClick()
ImgWidth = orgWidth
Call RotateImage
End Sub
Private Sub TextWidth_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim v As Long
If Shift = 1 Then v = 10 Else v = 1
Select Case KeyCode.Value
Case vbKeyF4, vbKeyTab
Exit Sub
Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
Exit Sub
Case vbKeyUp
If SpinWidth.Value + v <= SpinWidth.Max Then SpinWidth.Value = SpinWidth.Value + v
Case vbKeyDown
If SpinWidth.Value - v >= SpinWidth.Min Then SpinWidth.Value = SpinWidth.Value - v
End Select
If Shift = 4 Then Exit Sub
KeyCode.Value = 0
End Sub
Private Sub TextWidth_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii.Value < vbKey0 Or KeyAscii.Value > vbKey9 Then KeyAscii.Value = 0
End Sub
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Sub ResetImgSize()
ChkBxLAR.Enabled = False
ChkBxLockRect.Value = False
If hImg = 0 Then Exit Sub
Call GdipGetImageWidth(hImg, orgWidth)
Call GdipGetImageHeight(hImg, orgHeight)
TextSrcWidth.Text = orgWidth
TextSrcHeight.Text = orgHeight
SpinCropLeft.Max = orgWidth '- 1
SpinCropRight.Max = orgWidth
SpinCropTop.Max = orgHeight '- 1
SpinCropBottom.Max = orgHeight
SrcTop = 0
SrcLeft = 0
SrcRight = 0
SrcBottom = 0
ImgWidth = orgWidth
ImgHeight = orgHeight
LockedWidth = 0
LockedHeight = 0
ChkBxLAR.Enabled = True
End Sub
Private Sub ChkBxLAR_Click()
If ChkBxLAR.Value Then
If orgWidth > orgHeight Then
SpinWidth.Max = 9999
SpinHeight.Max = SpinWidth.Max * (orgHeight / orgWidth)
SpinHeight.Value = SpinWidth.Value * (orgHeight / orgWidth)
ElseIf orgWidth < orgHeight Then
SpinHeight.Max = 9999
SpinWidth.Max = SpinHeight.Max * (orgWidth / orgHeight)
SpinWidth.Value = SpinHeight.Value * (orgWidth / orgHeight)
End If
Else
SpinWidth.Max = 9999
SpinHeight.Max = 9999
End If
End Sub
Private Sub ChkBxDrawRect_Click()
Call RotateImage
End Sub
Private Sub ChkBxLockRect_Change()
If ChkBxLockRect.Value Then
LockedWidth = SrcRight + SrcLeft
LockedHeight = SrcBottom + SrcTop
SpinCropLeft.Max = LockedWidth
SpinCropRight.Max = LockedWidth
SpinCropTop.Max = LockedHeight
SpinCropBottom.Max = LockedHeight
Else
LockedWidth = 0
LockedHeight = 0
SpinCropLeft.Max = orgWidth
SpinCropRight.Max = orgWidth
SpinCropTop.Max = orgHeight
SpinCropBottom.Max = orgHeight
End If
End Sub
Private Sub ChkBxColorKey_Change()
Dim sw As Boolean
sw = ChkBxColorKey.Value
SpinHighR.Enabled = sw
TextHighR.Enabled = sw
SpinHighG.Enabled = sw
TextHighG.Enabled = sw
SpinHighB.Enabled = sw
TextHighB.Enabled = sw
SpinLowR.Enabled = sw
TextLowR.Enabled = sw
SpinLowG.Enabled = sw
TextLowG.Enabled = sw
SpinLowB.Enabled = sw
TextLowB.Enabled = sw
ChkBxRGBSync.Enabled = sw
' TextPointR.Enabled = sw
' TextPointG.Enabled = sw
' TextPointB.Enabled = sw
BtnHighColor.Enabled = sw
BtnLowColor.Enabled = sw
' BtnPointColor.Enabled = sw
Call RotateImage
End Sub
Private Sub OptReal_Change()
Call RotateImage
End Sub
Private Sub UserForm_Initialize()
#If Win64 Then
Debug.Print Now; "Running in 64-bit ver"
#Else
Debug.Print Now; "Running in 32-bit ver"
#End If
xdpi = GetDPI(LOGPIXELSX)
ydpi = GetDPI(LOGPIXELSY)
xlppi = Application.InchesToPoints(1)
sbBtnHeight = GetSystemMetrics(SM_CYVSCROLL) * xlppi / xdpi
sbBtnWidth = GetSystemMetrics(SM_CXHSCROLL) * xlppi / ydpi
gi.GdiplusVersion = 1&
Call GdiplusStartup(tkn, gi)
Call PrepareControls
Me.Caption = "Gdi+ ImageRotateFlip サンプル"
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
IsGetPxRunning = False
End Sub
Private Sub UserForm_Terminate()
If hImg Then hImg = GdipDisposeImage(hImg)
If hTmp Then hTmp = GdipDisposeImage(hTmp)
Call GdiplusShutdown(tkn)
End Sub
Private Sub PrepareControls()
Const IMG_SIZE As Single = 400 * 72! / 96!
Me.Font.Name = "MS UI Gothic"
Me.Font.Size = 9
Dim c As MSForms.Control
Set Frm1 = Me.Controls.Add("Forms.Frame.1", "Frm1")
Frm1.SpecialEffect = fmSpecialEffectFlat
Frm1.BorderStyle = fmBorderStyleNone
Frm1.ScrollBars = fmScrollBarsBoth
Set Img1 = Frm1.Controls.Add("Forms.Image.1", "Img1")
Img1.Height = IMG_SIZE
Img1.Width = IMG_SIZE
Frm1.Width = IMG_SIZE + sbBtnWidth
Frm1.Height = IMG_SIZE + sbBtnHeight
Set Btn1 = Me.Controls.Add("Forms.CommandButton.1", "Btn1")
Btn1.Caption = "Open"
Btn1.Accelerator = "O"
Btn1.AutoSize = True
Btn1.AutoSize = False
Btn1.Left = Frm1.Left + Frm1.Width
Set Btn2 = Me.Controls.Add("Forms.CommandButton.1", "Btn2")
Btn2.Width = Btn2.Height
Btn2.Left = Btn1.Left + Btn1.Width
Btn2.Caption = "Paste"
Btn2.Accelerator = "P"
Btn2.AutoSize = True
Btn2.AutoSize = False
Set Btn3 = Me.Controls.Add("Forms.CommandButton.1", "Btn3")
Btn3.Width = Btn3.Height * 2
Btn3.Caption = "+90deg"
Btn3.Accelerator = "D"
Btn3.AutoSize = True
Btn3.AutoSize = False
Btn3.Left = Btn2.Left + Btn2.Width + 3!
Set Btn4 = Me.Controls.Add("Forms.CommandButton.1", "Btn4")
Btn4.Caption = "Flip H"
Btn4.Accelerator = "F"
Btn4.AutoSize = True
Btn4.AutoSize = False
Btn4.Left = Btn3.Left + Btn3.Width + 3!
Set Btn5 = Me.Controls.Add("Forms.CommandButton.1", "Btn5")
Btn5.Caption = "Flip V"
Btn5.Accelerator = "V"
Btn5.AutoSize = True
Btn5.AutoSize = False
Btn5.Left = Btn4.Left + Btn4.Width
Set Btn6 = Me.Controls.Add("Forms.CommandButton.1", "Btn6")
Btn6.Caption = "Copy"
Btn6.Accelerator = "C"
Btn6.AutoSize = True
Btn6.AutoSize = False
Btn6.Left = Btn5.Left + Btn5.Width + 3!
Set Btn7 = Me.Controls.Add("Forms.CommandButton.1", "Btn7")
Btn7.Caption = "Save"
Btn7.Accelerator = "S"
Btn7.AutoSize = True
Btn7.AutoSize = False
Btn7.Left = Btn6.Left + Btn6.Width
Set c = Me.Controls.Add("Forms.Label.1", "LabelCrop")
c.Left = Btn1.Left + 3!
c.Top = Btn1.Height + 3!
c.Caption = "Crop"
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
Set TextCropLeft = Me.Controls.Add("Forms.TextBox.1", "TextCropLeft")
TextCropLeft.TextAlign = fmTextAlignRight
TextCropLeft.IMEMode = fmIMEModeDisable
TextCropLeft.ShowDropButtonWhen = fmShowDropButtonWhenAlways
TextCropLeft.DropButtonStyle = fmDropButtonStylePlain
EventOff = True
TextCropLeft.Text = "-0000"
TextCropLeft.AutoSize = True
TextCropLeft.AutoSize = False
TextCropLeft.MaxLength = 4
TextCropLeft.Text = "0"
EventOff = False
TextCropLeft.Top = c.Top + TextCropLeft.Height + 1.5!
TextCropLeft.Left = c.Left + c.Width
Set SpinCropLeft = Me.Controls.Add("Forms.SpinButton.1", "SpinCropLeft")
SpinCropLeft.Top = TextCropLeft.Top
SpinCropLeft.Left = TextCropLeft.Left + TextCropLeft.Width
SpinCropLeft.Height = TextCropLeft.Height
SpinCropLeft.Width = TextCropLeft.Height
SpinCropLeft.Orientation = fmOrientationHorizontal
EventOff = True
SpinCropLeft.Max = 9999
EventOff = False
With Me.Controls.Add("Forms.Label.1", "LabelCropLeft")
.Caption = "Left"
.Accelerator = "L"
.AutoSize = True
.AutoSize = False
.TabIndex = TextCropLeft.TabIndex
.Left = TextCropLeft.Left - .Width
.Top = TextCropLeft.Top + 3!
End With
Set TextCropTop = Me.Controls.Add("Forms.TextBox.1", "TextCropTop")
TextCropTop.TextAlign = fmTextAlignRight
TextCropTop.IMEMode = fmIMEModeDisable
TextCropTop.ShowDropButtonWhen = fmShowDropButtonWhenAlways
TextCropTop.DropButtonStyle = fmDropButtonStylePlain
EventOff = True
TextCropTop.Text = "-0000"
TextCropTop.AutoSize = True
TextCropTop.AutoSize = False
TextCropTop.MaxLength = 4
TextCropTop.Text = "0"
EventOff = False
TextCropTop.Top = c.Top
TextCropTop.Left = SpinCropLeft.Left + SpinCropLeft.Width + 1.5!
Set SpinCropTop = Me.Controls.Add("Forms.SpinButton.1", "SpinCropTop")
SpinCropTop.Top = TextCropTop.Top
SpinCropTop.Left = TextCropTop.Left + TextCropTop.Width
SpinCropTop.Height = TextCropTop.Height
SpinCropTop.Width = TextCropTop.Height
SpinCropTop.Orientation = fmOrientationVertical
SpinCropTop.SmallChange = -SpinCropTop.SmallChange
EventOff = True
SpinCropTop.Max = 9999
EventOff = False
With Me.Controls.Add("Forms.Label.1", "LabelCropTop")
.Caption = "Top"
.Accelerator = "T"
.AutoSize = True
.AutoSize = False
.TabIndex = TextCropTop.TabIndex
.Left = TextCropTop.Left - .Width
.Top = TextCropTop.Top
End With
Set TextCropRight = Me.Controls.Add("Forms.TextBox.1", "TextCropRight")
TextCropRight.TextAlign = fmTextAlignRight
TextCropRight.IMEMode = fmIMEModeDisable
TextCropRight.ShowDropButtonWhen = fmShowDropButtonWhenAlways
TextCropRight.DropButtonStyle = fmDropButtonStylePlain
EventOff = True
TextCropRight.Text = "-0000"
TextCropRight.AutoSize = True
TextCropRight.AutoSize = False
TextCropRight.MaxLength = 4
TextCropRight.Text = "0"
EventOff = False
TextCropRight.Top = TextCropLeft.Top
TextCropRight.Left = SpinCropTop.Left + SpinCropTop.Width + 1.5!
Set SpinCropRight = Me.Controls.Add("Forms.SpinButton.1", "SpinCropRight")
SpinCropRight.Top = TextCropRight.Top
SpinCropRight.Left = TextCropRight.Left + TextCropRight.Width
SpinCropRight.Height = TextCropRight.Height
SpinCropRight.Width = TextCropRight.Height
SpinCropRight.Orientation = fmOrientationHorizontal
SpinCropRight.SmallChange = -SpinCropRight.SmallChange
EventOff = True
SpinCropRight.Max = 9999
EventOff = False
With Me.Controls.Add("Forms.Label.1", "LabelCropRight")
.Caption = "Right"
.Accelerator = "R"
.AutoSize = True
.AutoSize = False
.TabIndex = TextCropRight.TabIndex
.Left = TextCropRight.Left '+ TextCropRight.Width - .Width
.Top = TextCropRight.Top - .Height
End With
Set TextCropBottom = Me.Controls.Add("Forms.TextBox.1", "TextCropBottom")
TextCropBottom.TextAlign = fmTextAlignRight
TextCropBottom.IMEMode = fmIMEModeDisable
TextCropBottom.ShowDropButtonWhen = fmShowDropButtonWhenAlways
TextCropBottom.DropButtonStyle = fmDropButtonStylePlain
EventOff = True
TextCropBottom.Text = "-0000"
TextCropBottom.AutoSize = True
TextCropBottom.AutoSize = False
TextCropBottom.MaxLength = 4
TextCropBottom.Text = "0"
EventOff = False
TextCropBottom.Top = c.Top + TextCropLeft.Height * 2 + 3!
TextCropBottom.Left = TextCropTop.Left
Set SpinCropBottom = Me.Controls.Add("Forms.SpinButton.1", "SpinCropBottom")
SpinCropBottom.Top = TextCropBottom.Top
SpinCropBottom.Left = TextCropBottom.Left + TextCropBottom.Width
SpinCropBottom.Height = TextCropBottom.Height
SpinCropBottom.Width = TextCropBottom.Height
SpinCropBottom.Orientation = fmOrientationVertical
EventOff = True
SpinCropBottom.Max = 9999
EventOff = False
With Me.Controls.Add("Forms.Label.1", "LabelCropBottom")
.Caption = "Bottom"
.Accelerator = "B"
.AutoSize = True
.AutoSize = False
.TabIndex = TextCropBottom.TabIndex
.Left = TextCropBottom.Left - .Width
.Top = TextCropBottom.Top '- .Height
End With
Set BtnBkColor = Me.Controls.Add("Forms.CommandButton.1", "BtnBkColor")
BtnBkColor.PicturePosition = fmPicturePositionCenter
BkColor1 = &HFFFFFFFF
BkColor2 = &HFFCCCCCC
Set BtnBkColor.Picture = CreateCheckerPic(BkColor1, BkColor2, 5, 3, 3)
BtnBkColor.AutoSize = True
BtnBkColor.AutoSize = False
BtnBkColor.TakeFocusOnClick = False
BtnBkColor.Width = BtnBkColor.Height
BtnBkColor.Top = TextCropBottom.Top
BtnBkColor.Left = Btn1.Left + 3!
Set c = Me.Controls.Add("Forms.Label.1", "LabelScrWidth")
c.Caption = "Original"
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
c.Top = TextCropBottom.Top + TextCropBottom.Height + 6!
c.Left = Btn1.Left + 3!
Set TextSrcWidth = Me.Controls.Add("Forms.TextBox.1", "TextSrcWidth")
TextSrcWidth.Top = c.Top
c.Top = c.Top + 3!
TextSrcWidth.Left = c.Left + c.Width
TextSrcWidth.Text = "-0000"
TextSrcWidth.AutoSize = True
TextSrcWidth.AutoSize = False
TextSrcWidth.Text = "0"
TextSrcWidth.Locked = True
TextSrcWidth.TextAlign = fmTextAlignRight
TextSrcWidth.IMEMode = fmIMEModeDisable
TextSrcWidth.BackStyle = fmBackStyleTransparent
TextSrcWidth.TabStop = False
Set c = Me.Controls.Add("Forms.Label.1", "LabelScrHeight")
c.Left = TextSrcWidth.Left + TextSrcWidth.Width + 1.5!
c.Caption = "x"
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
c.Top = TextSrcWidth.Top + (TextSrcWidth.Height - c.Height)
Set TextSrcHeight = Me.Controls.Add("Forms.TextBox.1", "TextSrcHeight")
TextSrcHeight.Top = TextSrcWidth.Top
TextSrcHeight.Left = c.Left + c.Width
TextSrcHeight.Text = "-0000"
TextSrcHeight.AutoSize = True
TextSrcHeight.AutoSize = False
TextSrcHeight.Text = "0"
TextSrcHeight.Locked = True
TextSrcHeight.TextAlign = fmTextAlignRight
TextSrcHeight.IMEMode = fmIMEModeDisable
TextSrcHeight.BackStyle = fmBackStyleTransparent
TextSrcHeight.TabStop = False
Set c = Me.Controls.Add("Forms.Label.1", "LabelCropWidth")
c.Left = TextSrcHeight.Left + TextSrcHeight.Width + 3!
c.Top = TextSrcHeight.Top
c.Top = c.Top + 3!
c.Caption = " =>"
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
Set TextCropWidth = Me.Controls.Add("Forms.TextBox.1", "TextCropWidth")
TextCropWidth.Top = TextSrcHeight.Top
TextCropWidth.Left = c.Left + c.Width + 3!
TextCropWidth.Text = "-0000"
TextCropWidth.AutoSize = True
TextCropWidth.AutoSize = False
TextCropWidth.Text = "0"
TextCropWidth.Locked = True
TextCropWidth.TextAlign = fmTextAlignRight
TextCropWidth.IMEMode = fmIMEModeDisable
TextCropWidth.BackStyle = fmBackStyleTransparent
TextCropWidth.TabStop = False
Set c = Me.Controls.Add("Forms.Label.1", "LabelCropHeight")
c.Left = TextCropWidth.Left + TextCropWidth.Width + 1.5!
c.Top = TextSrcHeight.Top
c.Caption = "x"
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
c.Top = TextCropWidth.Top + (TextCropWidth.Height - c.Height)
Set TextCropHeight = Me.Controls.Add("Forms.TextBox.1", "TextCropHeight")
TextCropHeight.Top = TextCropWidth.Top
TextCropHeight.Left = c.Left + c.Width + 1.5!
TextCropHeight.Text = "-0000"
TextCropHeight.AutoSize = True
TextCropHeight.AutoSize = False
TextCropHeight.Text = "0"
TextCropHeight.Locked = True
TextCropHeight.TextAlign = fmTextAlignRight
TextCropHeight.IMEMode = fmIMEModeDisable
TextCropHeight.BackStyle = fmBackStyleTransparent
TextCropHeight.TabStop = False
Set ChkBxLockRect = Me.Controls.Add("Forms.CheckBox.1", "ChkBxLockRect")
ChkBxLockRect.Top = TextCropTop.Top
ChkBxLockRect.Left = TextCropRight.Left + TextCropRight.Width - sbBtnWidth
ChkBxLockRect.Caption = szChrW(128274) & " Size(Z)"
ChkBxLockRect.Accelerator = "Z"
ChkBxLockRect.AutoSize = True
ChkBxLockRect.AutoSize = False
Set ChkBxDrawRect = Me.Controls.Add("Forms.CheckBox.1", "ChkBxDrawRect")
ChkBxDrawRect.Top = TextCropBottom.Top
ChkBxDrawRect.Left = SpinCropBottom.Left + SpinCropBottom.Width + sbBtnWidth
ChkBxDrawRect.Caption = "BoundingBox"
ChkBxDrawRect.Accelerator = "X"
ChkBxDrawRect.AutoSize = True
ChkBxDrawRect.AutoSize = False
With Me.Controls.Add("Forms.Label.1", "LabelSep1")
.SpecialEffect = fmSpecialEffectSunken
.Height = 2.25!
.Width = Btn7.Left + Btn7.Width - Btn1.Left - 6!
.Top = TextCropWidth.Top + TextCropWidth.Height + 3!
.Left = Btn1.Left + 3!
End With
Set c = Me.Controls.Add("Forms.Label.1", "LabelScale")
c.Left = Btn1.Left + 3!
c.Top = TextCropWidth.Top + TextCropWidth.Height + 6!
c.Caption = "Scale"
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
Set c = Me.Controls.Add("Forms.Label.1", "LabelW")
c.Left = Me.Controls("LabelScale").Left + 3!
c.Top = Me.Controls("LabelScale").Top + Me.Controls("LabelScale").Height + 1.5!
c.Caption = "Width"
c.Accelerator = "W"
c.AutoSize = True
c.AutoSize = False
Set TextWidth = Me.Controls.Add("Forms.TextBox.1", "TextWidth")
TextWidth.Top = c.Top
c.Top = c.Top + 1.5!
TextWidth.Left = c.Left + c.Width
TextWidth.TextAlign = fmTextAlignRight
TextWidth.IMEMode = fmIMEModeDisable
TextWidth.ShowDropButtonWhen = fmShowDropButtonWhenAlways
TextWidth.DropButtonStyle = fmDropButtonStylePlain
EventOff = True
TextWidth.Text = "-0000"
TextWidth.AutoSize = True
TextWidth.AutoSize = False
TextWidth.MaxLength = 4
TextWidth.Text = "1"
EventOff = False
Set SpinWidth = Me.Controls.Add("Forms.SpinButton.1", "SpinWidth")
SpinWidth.Top = TextWidth.Top
SpinWidth.Left = TextWidth.Left + TextWidth.Width
SpinWidth.Height = TextWidth.Height
SpinWidth.Orientation = fmOrientationVertical
EventOff = True
SpinWidth.Min = 1
SpinWidth.Max = 9999
EventOff = False
Set c = Me.Controls.Add("Forms.Label.1", "LabelH")
c.Left = SpinWidth.Left + SpinWidth.Width + sbBtnWidth
c.Top = Me.Controls("LabelScale").Top + Me.Controls("LabelScale").Height + 1.5!
c.Caption = "Height"
c.Accelerator = "H"
c.AutoSize = True
c.AutoSize = False
Set TextHeight = Me.Controls.Add("Forms.TextBox.1", "TextHeight")
TextHeight.Top = c.Top
c.Top = c.Top + 1.5!
TextHeight.Left = c.Left + c.Width
TextHeight.TextAlign = fmTextAlignRight
TextHeight.IMEMode = fmIMEModeDisable
TextHeight.ShowDropButtonWhen = fmShowDropButtonWhenAlways
TextHeight.DropButtonStyle = fmDropButtonStylePlain
EventOff = True
TextHeight.Text = "-0000"
TextHeight.AutoSize = True
TextHeight.AutoSize = False
TextHeight.MaxLength = 4
TextHeight.Text = "1"
EventOff = False
Set SpinHeight = Me.Controls.Add("Forms.SpinButton.1", "SpinHeight")
SpinHeight.Top = TextHeight.Top
SpinHeight.Left = TextHeight.Left + TextHeight.Width
SpinHeight.Height = TextWidth.Height
SpinHeight.Orientation = fmOrientationVertical
EventOff = True
SpinHeight.Min = 1
SpinHeight.Max = 9999
EventOff = False
Set ChkBxLAR = Me.Controls.Add("Forms.CheckBox.1", "ChkBxLAR")
ChkBxLAR.Left = TextWidth.Left + TextHeight.Width
ChkBxLAR.Top = SpinHeight.Top + SpinHeight.Height + 1.5!
ChkBxLAR.Width = ChkBxLAR.Width * 2
ChkBxLAR.Caption = szChrW(128274) & " Aspect-Ratio(G)"
ChkBxLAR.AutoSize = True
ChkBxLAR.Accelerator = "G"
ChkBxLAR.Enabled = False
Set c = Me.Controls.Add("Forms.Label.1", "LabelDivMode")
c.Left = SpinHeight.Left + SpinHeight.Width + 3!
c.Top = Me.Controls("LabelScale").Top
c.Caption = "calculate with"
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
Set OptInt = Me.Controls.Add("Forms.OptionButton.1", "OptInt")
OptInt.Caption = "INT"
OptInt.Accelerator = "N"
OptInt.AutoSize = True
OptInt.AutoSize = False
OptInt.Left = SpinHeight.Left + SpinHeight.Width + sbBtnWidth
OptInt.Top = c.Top + c.Height
Set OptReal = Me.Controls.Add("Forms.OptionButton.1", "OptReal")
OptReal.Caption = "REAL"
OptReal.AutoSize = True
OptReal.AutoSize = False
OptReal.Value = True
OptReal.Left = OptInt.Left
OptReal.Top = OptInt.Top + OptInt.Height
Set c = Me.Controls.Add("Forms.Label.1", "LabelA")
c.Left = Btn1.Left + 3!
c.Top = ChkBxLAR.Top + sbBtnHeight
c.Caption = "Angle"
c.Accelerator = "A"
c.AutoSize = True
c.AutoSize = False
Set SBar1 = Me.Controls.Add("Forms.ScrollBar.1", "SBar1")
SBar1.Width = 200 * 72! / 96! + sbBtnWidth * 2
SBar1.Orientation = fmOrientationHorizontal
SBar1.Left = c.Left + 6!
SBar1.Top = c.Top + c.Height + 1.5!
SBar1.Min = -18000
SBar1.Max = 18000
SBar1.LargeChange = 1000
SBar1.SmallChange = 100
Set TextAngle = Me.Controls.Add("Forms.TextBox.1", "TextAngle")
TextAngle.Left = SBar1.Left + SBar1.Width
TextAngle.Top = SBar1.Top
TextAngle.TextAlign = fmTextAlignRight
TextAngle.IMEMode = fmIMEModeDisable
TextAngle.ShowDropButtonWhen = fmShowDropButtonWhenAlways
TextAngle.DropButtonStyle = fmDropButtonStylePlain
TextAngle.Text = "-000.00"
TextAngle.AutoSize = True
TextAngle.AutoSize = False
SBar1.Height = TextAngle.Height
TextAngle.Text = "0"
Set SpinAngle = Me.Controls.Add("Forms.SpinButton.1", "SpinAngle")
SpinAngle.Left = TextAngle.Left + TextAngle.Width
SpinAngle.Top = SBar1.Top
SpinAngle.Height = TextAngle.Height
SpinAngle.Orientation = fmOrientationVertical
SpinAngle.Min = SBar1.Min
SpinAngle.Max = SBar1.Max
SpinAngle.SmallChange = 5
Set ChkBxPOM = Me.Controls.Add("Forms.CheckBox.1", "ChkBxPOM")
ChkBxPOM.Left = Btn1.Left + sbBtnWidth
ChkBxPOM.Top = SpinAngle.Top + SpinAngle.Height + 6!
ChkBxPOM.Width = ChkBxPOM.Width * 2
ChkBxPOM.Caption = "0.5PixelOffset"
ChkBxPOM.AutoSize = True
ChkBxPOM.Accelerator = "M"
Set c = Me.Controls.Add("Forms.Label.1", "LabelInterpolationMode")
c.Left = ChkBxPOM.Left + ChkBxPOM.Width + sbBtnWidth + 3!
c.Top = ChkBxPOM.Top
c.Width = c.Width * 2
c.Caption = "Interpolation"
c.Accelerator = "I"
c.AutoSize = True
c.AutoSize = False
Set ComboInterpolationMode = Me.Controls.Add("Forms.ComboBox.1", "ComboInterpolationMode")
ComboInterpolationMode.Left = c.Left + c.Width
ComboInterpolationMode.Top = c.Top
c.Top = c.Top + 1.5!
ComboInterpolationMode.style = fmStyleDropDownList
ComboInterpolationMode.AddItem "Default"
ComboInterpolationMode.AddItem "LowQuality"
ComboInterpolationMode.AddItem "HighQuality"
ComboInterpolationMode.AddItem "Bilinear"
ComboInterpolationMode.AddItem "Bicubic"
ComboInterpolationMode.AddItem "NearestNeighbor"
ComboInterpolationMode.AddItem "HighQualityBilinear"
ComboInterpolationMode.AddItem "QualityBicubic"
ComboInterpolationMode.SelectionMargin = False
EventOff = True
ComboInterpolationMode.ListIndex = 6
ComboInterpolationMode.AutoSize = True
ComboInterpolationMode.AutoSize = False
ComboInterpolationMode.ListIndex = 0
EventOff = False
With Me.Controls.Add("Forms.Label.1", "LabelSep2")
.SpecialEffect = fmSpecialEffectSunken
.Height = 2.25!
.Width = Btn7.Left + Btn7.Width - Btn1.Left - 6!
.Top = ComboInterpolationMode.Top + ComboInterpolationMode.Height + 3!
.Left = Btn1.Left + 3!
End With
Set ChkBxColorKey = Me.Controls.Add("Forms.CheckBox.1", "ChkBxColorKey")
ChkBxColorKey.Left = Btn1.Left + 3!
ChkBxColorKey.Top = ComboInterpolationMode.Top + ComboInterpolationMode.Height + 6!
ChkBxColorKey.Caption = "ColorKey"
ChkBxColorKey.Accelerator = "E"
ChkBxColorKey.AutoSize = True
ChkBxColorKey.AutoSize = False
Set c = Me.Controls.Add("Forms.Label.1", "LabelColorKeyHigh")
c.Caption = "High"
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
c.Top = ChkBxColorKey.Top + ChkBxColorKey.Height
c.Left = ChkBxColorKey.Left + sbBtnWidth
Set c = Me.Controls.Add("Forms.Label.1", "LabelColorKeyHighR")
c.Caption = "R"
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
c.Top = ChkBxColorKey.Top + ChkBxColorKey.Height
c.Left = Me.Controls("LabelColorKeyHigh").Left + Me.Controls("LabelColorKeyHigh").Width + 1.5!
Set TextHighR = Me.Controls.Add("Forms.TextBox.1", "TextHighR")
TextHighR.TextAlign = fmTextAlignRight
TextHighR.IMEMode = fmIMEModeDisable
TextHighR.ShowDropButtonWhen = fmShowDropButtonWhenAlways
TextHighR.DropButtonStyle = fmDropButtonStylePlain
EventOff = True
TextHighR.Text = "255"
TextHighR.AutoSize = True
TextHighR.AutoSize = False
TextHighR.MaxLength = 3
TextHighR.Enabled = False
EventOff = False
TextHighR.Top = c.Top
TextHighR.Left = c.Left + c.Width
Set SpinHighR = Me.Controls.Add("Forms.SpinButton.1", "SpinHighR")
SpinHighR.Top = TextHighR.Top
SpinHighR.Left = TextHighR.Left + TextHighR.Width
SpinHighR.Height = TextHighR.Height
SpinHighR.Orientation = fmOrientationVertical
EventOff = True
SpinHighR.Max = 255
SpinHighR.Value = SpinHighR.Max
SpinHighR.Enabled = False
EventOff = False
Set c = Me.Controls.Add("Forms.Label.1", "LabelColorKeyHighG")
c.Caption = "G"
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
c.Top = SpinHighR.Top
c.Left = SpinHighR.Left + SpinHighR.Width + 3!
Set TextHighG = Me.Controls.Add("Forms.TextBox.1", "TextHighG")
TextHighG.TextAlign = fmTextAlignRight
TextHighG.IMEMode = fmIMEModeDisable
TextHighG.ShowDropButtonWhen = fmShowDropButtonWhenAlways
TextHighG.DropButtonStyle = fmDropButtonStylePlain
EventOff = True
TextHighG.Text = "255"
TextHighG.AutoSize = True
TextHighG.AutoSize = False
TextHighG.MaxLength = 3
TextHighG.Enabled = False
EventOff = False
TextHighG.Top = c.Top
TextHighG.Left = c.Left + c.Width
Set SpinHighG = Me.Controls.Add("Forms.SpinButton.1", "SpinHighG")
SpinHighG.Top = TextHighG.Top
SpinHighG.Left = TextHighG.Left + TextHighG.Width
SpinHighG.Height = TextHighG.Height
SpinHighG.Orientation = fmOrientationVertical
SpinHighG.Enabled = False
EventOff = True
SpinHighG.Max = 255
SpinHighG.Value = SpinHighG.Max
SpinHighG.Enabled = False
EventOff = False
Set c = Me.Controls.Add("Forms.Label.1", "LabelColorKeyHighB")
c.Caption = "B"
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
c.Top = SpinHighG.Top
c.Left = SpinHighG.Left + SpinHighG.Width + 3!
Set TextHighB = Me.Controls.Add("Forms.TextBox.1", "TextHighB")
TextHighB.TextAlign = fmTextAlignRight
TextHighB.IMEMode = fmIMEModeDisable
TextHighB.ShowDropButtonWhen = fmShowDropButtonWhenAlways
TextHighB.DropButtonStyle = fmDropButtonStylePlain
EventOff = True
TextHighB.Text = "255"
TextHighB.AutoSize = True
TextHighB.AutoSize = False
TextHighB.MaxLength = 3
TextHighB.Enabled = False
EventOff = False
TextHighB.Top = c.Top
TextHighB.Left = c.Left + c.Width
Set SpinHighB = Me.Controls.Add("Forms.SpinButton.1", "SpinHighB")
SpinHighB.Top = TextHighB.Top
SpinHighB.Left = TextHighB.Left + TextHighB.Width
SpinHighB.Height = TextHighB.Height
SpinHighB.Orientation = fmOrientationVertical
EventOff = True
SpinHighB.Max = 255
SpinHighB.Value = SpinHighB.Max
SpinHighB.Enabled = False
EventOff = False
Set BtnHighColor = Me.Controls.Add("Forms.CommandButton.1", "BtnHighColor")
BtnHighColor.TakeFocusOnClick = False
BtnHighColor.PicturePosition = fmPicturePositionCenter
BtnHighColor.Picture = Application.CommandBars.GetImageMso("PasteApplyStyle", 16, 16)
BtnHighColor.BackColor = &HFFFFFF
' BtnHighColor.Width = TextHighB.Width - sbBtnWidth
' BtnHighColor.Height = TextHighB.Height
BtnHighColor.AutoSize = True
BtnHighColor.AutoSize = False
BtnHighColor.Top = TextHighB.Top - (BtnHighColor.Height - TextHighB.Height)
BtnHighColor.Left = SpinHighB.Left + SpinHighB.Width + 1.5!
BtnHighColor.Enabled = False
Set c = Me.Controls.Add("Forms.Label.1", "LabelColorKeyLow")
c.Caption = "Low"
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
c.Top = SpinHighB.Top + SpinHighB.Height
c.Left = ChkBxColorKey.Left + sbBtnWidth
Set c = Me.Controls.Add("Forms.Label.1", "LabelColorKeyLowR")
c.Caption = "R"
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
c.Top = SpinHighB.Top + SpinHighB.Height
c.Left = Me.Controls("LabelColorKeyHigh").Left + Me.Controls("LabelColorKeyHigh").Width + 1.5!
Set TextLowR = Me.Controls.Add("Forms.TextBox.1", "TextLowR")
TextLowR.TextAlign = fmTextAlignRight
TextLowR.IMEMode = fmIMEModeDisable
TextLowR.ShowDropButtonWhen = fmShowDropButtonWhenAlways
TextLowR.DropButtonStyle = fmDropButtonStylePlain
EventOff = True
TextLowR.Text = "255"
TextLowR.AutoSize = True
TextLowR.AutoSize = False
TextLowR.MaxLength = 3
TextLowR.Enabled = False
EventOff = False
TextLowR.Top = c.Top
TextLowR.Left = c.Left + c.Width
Set SpinLowR = Me.Controls.Add("Forms.SpinButton.1", "SpinLowR")
SpinLowR.Top = TextLowR.Top
SpinLowR.Left = TextLowR.Left + TextLowR.Width
SpinLowR.Height = TextLowR.Height
SpinLowR.Orientation = fmOrientationVertical
EventOff = True
SpinLowR.Max = 255
SpinLowR.Value = SpinLowR.Max
SpinLowR.Enabled = False
EventOff = False
Set c = Me.Controls.Add("Forms.Label.1", "LabelColorKeyLowG")
c.Caption = "G"
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
c.Top = SpinLowR.Top
c.Left = SpinLowR.Left + SpinLowR.Width + 3!
Set TextLowG = Me.Controls.Add("Forms.TextBox.1", "TextLowG")
TextLowG.TextAlign = fmTextAlignRight
TextLowG.IMEMode = fmIMEModeDisable
TextLowG.ShowDropButtonWhen = fmShowDropButtonWhenAlways
TextLowG.DropButtonStyle = fmDropButtonStylePlain
EventOff = True
TextLowG.Text = "255"
TextLowG.AutoSize = True
TextLowG.AutoSize = False
TextLowG.MaxLength = 3
TextLowG.Enabled = False
EventOff = False
TextLowG.Top = c.Top
TextLowG.Left = c.Left + c.Width
Set SpinLowG = Me.Controls.Add("Forms.SpinButton.1", "SpinLowG")
SpinLowG.Top = TextLowG.Top
SpinLowG.Left = TextLowG.Left + TextLowG.Width
SpinLowG.Height = TextLowG.Height
SpinLowG.Orientation = fmOrientationVertical
EventOff = True
SpinLowG.Max = 255
SpinLowG.Value = SpinLowG.Max
SpinLowG.Enabled = False
EventOff = False
Set c = Me.Controls.Add("Forms.Label.1", "LabelColorKeyLowB")
c.Caption = "B"
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
c.Top = SpinLowR.Top
c.Left = SpinLowG.Left + SpinLowG.Width + 3!
Set TextLowB = Me.Controls.Add("Forms.TextBox.1", "TextLowB")
TextLowB.TextAlign = fmTextAlignRight
TextLowB.IMEMode = fmIMEModeDisable
TextLowB.ShowDropButtonWhen = fmShowDropButtonWhenAlways
TextLowB.DropButtonStyle = fmDropButtonStylePlain
EventOff = True
TextLowB.Text = "255"
TextLowB.AutoSize = True
TextLowB.AutoSize = False
TextLowB.MaxLength = 3
TextLowB.Enabled = False
EventOff = False
TextLowB.Top = c.Top
TextLowB.Left = c.Left + c.Width
Set SpinLowB = Me.Controls.Add("Forms.SpinButton.1", "SpinLowB")
SpinLowB.Top = TextLowB.Top
SpinLowB.Left = TextLowB.Left + TextLowB.Width
SpinLowB.Height = TextLowB.Height
SpinLowB.Orientation = fmOrientationVertical
EventOff = True
SpinLowB.Max = 255
SpinLowB.Value = SpinLowB.Max
SpinLowB.Enabled = False
EventOff = False
Set BtnLowColor = Me.Controls.Add("Forms.CommandButton.1", "BtnLowColor")
BtnLowColor.TakeFocusOnClick = False
BtnLowColor.PicturePosition = fmPicturePositionCenter
BtnLowColor.Picture = Application.CommandBars.GetImageMso("PasteApplyStyle", 16, 16)
BtnLowColor.BackColor = &HFFFFFF
' BtnLowColor.Width = TextLowB.Width - sbBtnWidth
' BtnLowColor.Height = TextLowB.Height
BtnLowColor.AutoSize = True
BtnLowColor.AutoSize = False
BtnLowColor.Top = TextLowB.Top
BtnLowColor.Left = SpinLowB.Left + SpinLowB.Width + 1.5!
BtnLowColor.Enabled = False
Set ChkBxRGBSync = Me.Controls.Add("Forms.CheckBox.1", "ChkBxRGBSync")
ChkBxRGBSync.Left = SpinLowG.Left
ChkBxRGBSync.Top = ChkBxColorKey.Top
ChkBxRGBSync.Caption = szChrW(128279) & " R=G=B"
ChkBxRGBSync.Accelerator = "K"
ChkBxRGBSync.AutoSize = True
ChkBxRGBSync.AutoSize = False
ChkBxRGBSync.Enabled = False
Set ImgColorKeyGradient = Me.Controls.Add("Forms.Image.1", "ImgColorKeyGradient")
ImgColorKeyGradient.PictureSizeMode = fmPictureSizeModeStretch
ImgColorKeyGradient.BackStyle = fmBackStyleTransparent
ImgColorKeyGradient.Height = TextLowB.Height
ImgColorKeyGradient.Width = 258 * 72! / 96!
ImgColorKeyGradient.Left = ChkBxColorKey.Left + sbBtnWidth
ImgColorKeyGradient.Top = TextLowB.Top + TextLowB.Height + 1.5!
Call UpdateColorKeySample
Set BtnPointColor = Me.Controls.Add("Forms.ToggleButton.1", "BtnPointColor")
BtnPointColor.PicturePosition = fmPicturePositionCenter
BtnPointColor.Picture = Application.CommandBars.GetImageMso("PickUpStyle", 16, 16)
BtnPointColor.AutoSize = True
BtnPointColor.AutoSize = False
BtnPointColor.Top = ImgColorKeyGradient.Top + ImgColorKeyGradient.Height + 1.5!
BtnPointColor.Left = ImgColorKeyGradient.Left
Set LabelPointColorMsg = Me.Controls.Add("Forms.Label.1", "LabelPointColorMsg")
LabelPointColorMsg.Width = ImgColorKeyGradient.Width
LabelPointColorMsg.Caption = "(press [Esc] to stop)"
LabelPointColorMsg.AutoSize = True
LabelPointColorMsg.AutoSize = False
LabelPointColorMsg.Top = BtnPointColor.Top + (BtnPointColor.Height - c.Height) / 2
LabelPointColorMsg.Left = BtnPointColor.Left + BtnPointColor.Width + 3!
LabelPointColorMsg.Visible = False
Set TextPointR = Me.Controls.Add("Forms.TextBox.1", "TextPointR")
TextPointR.TextAlign = fmTextAlignRight
TextPointR.IMEMode = fmIMEModeDisable
TextPointR.BackStyle = fmBackStyleTransparent
TextPointR.Text = "255"
TextPointR.AutoSize = True
TextPointR.AutoSize = False
TextPointR.MaxLength = 3
TextPointR.Locked = True
TextPointR.Top = BtnPointColor.Top + (BtnPointColor.Height - TextPointR.Height) / 2
TextPointR.Left = LabelPointColorMsg.Left + LabelPointColorMsg.Width + 3!
Set c = Me.Controls.Add("Forms.Label.1", "LabelColorKeyPointG")
c.Caption = ","
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
c.Top = TextPointR.Top + TextPointR.Height - c.Height
c.Left = TextPointR.Left + TextPointR.Width + 3!
Set TextPointG = Me.Controls.Add("Forms.TextBox.1", "TextPointG")
TextPointG.TextAlign = fmTextAlignRight
TextPointG.IMEMode = fmIMEModeDisable
TextPointG.BackStyle = fmBackStyleTransparent
TextPointG.Text = "255"
TextPointG.AutoSize = True
TextPointG.AutoSize = False
TextPointG.MaxLength = 3
TextPointG.Locked = True
TextPointG.Top = TextPointR.Top
TextPointG.Left = c.Left + c.Width
Set c = Me.Controls.Add("Forms.Label.1", "LabelColorKeyPointB")
c.Caption = ","
c.Accelerator = ""
c.AutoSize = True
c.AutoSize = False
c.Top = TextPointG.Top + TextPointG.Height - c.Height
c.Left = TextPointG.Left + TextPointG.Width + 3!
Set TextPointB = Me.Controls.Add("Forms.TextBox.1", "TextPointB")
TextPointB.TextAlign = fmTextAlignRight
TextPointB.IMEMode = fmIMEModeDisable
TextPointB.BackStyle = fmBackStyleTransparent
TextPointB.Text = "255"
TextPointB.AutoSize = True
TextPointB.AutoSize = False
TextPointB.MaxLength = 3
TextPointB.Locked = True
TextPointB.Top = TextPointG.Top
TextPointB.Left = c.Left + c.Width
Set LabelPickedColor = Me.Controls.Add("Forms.Label.1", "LabelPickedColor")
LabelPickedColor.Height = TextPointB.Width
LabelPickedColor.Width = TextPointB.Width
LabelPickedColor.SpecialEffect = fmSpecialEffectBump
LabelPickedColor.BackColor = &HFFFFFF
LabelPickedColor.Left = TextPointB.Left + TextPointB.Width + 3!
LabelPickedColor.Top = BtnLowColor.Top + BtnLowColor.Height + 3!
Set LabelPointColor = Me.Controls.Add("Forms.Label.1", "LabelPointColor")
LabelPointColor.Height = (LabelPickedColor.Height - 3!) / 2!
LabelPointColor.Width = LabelPickedColor.Width - 3!
LabelPointColor.Left = LabelPickedColor.Left + 1.5!
LabelPointColor.Top = LabelPickedColor.Top + 1.5!
LabelPointColor.BackColor = &HFFFFFF
Call SetMySize
End Sub
（白茶） 2025/02/22(土) 00:34:35
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.