Bird-Soft Weblog

前回の記事のVBAのプログラムを変更してパレットを変更するようにしてみました。
これで50色程度までなら元の画像と同じようにExcel上に表示できます。
（あまり意味はないVBAスクリプトですが＾＾；）

また、前回わかりやすいように冗長化していた部分を排除し、
さらに描画処理を一時的に停止することにより高速化しました。

※画像はあらかじめ50色以下に減色しておいてください。
※パレットを変更するので、他のExcelで開いているファイルは
閉じておいたほうがよいです。
※エラー処理は省略しているので、画像より大きい範囲に対して
　GetPixelしたりしないでください。。



VBAサンプルは続きから

あらかじめCommandButton1、Image1をUserFormに作成しておきます。
　今回もコードはUserForm1だけに書くだけでよいです。
　C:\test.bmp"にテスト用の画像を配置しておきます。
　（サンプルでは160*160まで。重くなるが、コード変更でさらに大きい画像でも対応可）

Private Const DT_LEFT As Long = &H0 Private Const DT_BOTTOM As Long = &H8 Private Const DT_SINGLELINE As Long = &H20 Private Const TRANSPARENT As Long = 1 Private Const GUID_IDISPATCH_INTERFACE As String = "{00020400-0000-0000-C000-000000000046}" Private Const CF_BITMAP As Long = 2 Private Const CF_PALETTE As Long = 9 Private Const PICTYPE_BITMAP As Long = 1 Private Const IMAGE_BITMAP As Long = 0 Private Const LR_COPYRETURNORG As Long = &H4 Private Const LR_LOADFROMFILE As Long = &H10 Private Const LOGPIXELSX As Long = 88 Private Type BITMAP bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End Type Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function GetObject Lib "gdi32" _ Alias "GetObjectA" _ (ByVal hObject As Long, _ ByVal nCount As Long, _ ByRef lpObject As Any) As Long Private Declare Function SelectObject Lib "gdi32" _ (ByVal hDC As Long, _ ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long '★ Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long Private Sub CommandButton1_Click() Const FILE_ORIGINAL As String = "C:\test.bmp" Dim hDC As Long Dim hBmp As Long Dim hOrgBmp As Long Dim hOrgFont As Long Dim hPalette As Long Dim hImg As Long Dim tBitmap As BITMAP Dim Pic As stdole.IPictureDisp Dim Ratio As Single '---------- Dim i, j, cnt Dim strBGR, strBGR_Pixel Dim FlagHit '検索がヒットしたか Dim PPos 'パレットの位置 Dim ii Dim ret RRt = 255 '検索対象 GGt = 255 BBt = 100 PPos = 1 FlagHit = 0 '---------- 'On Error Resume Next With Me.Image1 'Image1に元画像を表示 .Picture = stdole.LoadPicture(FILE_ORIGINAL) .AutoSize = False .AutoSize = True End With '元画像ＢＭＰファイルからデバイスコンテキストを直接作成 hBmp = LoadImage(0, FILE_ORIGINAL, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE) hDC = CreateCompatibleDC(0) hOrgBmp = SelectObject(hDC, hBmp) GetObject hBmp, Len(tBitmap), tBitmap '---------- '★下位から 8 ビット単位で B、G、R、未使用の順に並んでいます 'MsgBox (Hex(GetPixel(hDC, 1, 1))) 'セルの幅を変更 Columns("A:IV").Select Selection.ColumnWidth = 0.62 Rows("1:510").Select Selection.RowHeight = 6 '★描画更新停止 ThisWorkbook.Application.ScreenUpdating = False For j = 1 To 160 Step 1 '縦方向 For i = 1 To 160 Step 1 '横方向 strBGR_Pixel = GetPixel(hDC, i - 1, j - 1) 'ピクセル取得 '----------------------------------- '最初からPPosまでのパレットを検索 '見つかったらそれを適用。 'なかったらPPos+1のパレットを変更してしまう FlagHit = 0 For ii = 1 To PPos Step 1 strBGR = ThisWorkbook.Colors(ii) 'パレットの色を取得 If strBGR = strBGR_Pixel Then '既存パレットに同色があったとき FlagHit = 1 Cells(j, i).Interior.ColorIndex = ii 'ヒットしたパレットを適用 End If Next ii '色がパレットにないとき、パレット変更 If FlagHit = 0 Then If PPos = 56 Then '★描画更新有効 ThisWorkbook.Application.ScreenUpdating = True MsgBox "パレットが足りません! PPos:" & PPos For ii = 1 To 56 Step 1 strBGR = ThisWorkbook.Colors(ii) Cells(ii, 1).Value = strBGR 'DBG Next ii Exit Sub End If ThisWorkbook.Colors(PPos + 1) = strBGR_Pixel 'パレット変更 Cells(j, i).Interior.ColorIndex = PPos + 1 '変更したパレットを適用 PPos = PPos + 1 End If '------------------------------------- Next i Next j SelectObject hDC, hOrgFont SelectObject hDC, hOrgBmp '描画オブジェクト／デバイスコンテキストの後始末 DeleteDC hDC DeleteObject hBmp '★描画更新有効 ThisWorkbook.Application.ScreenUpdating = True End Sub

投稿者: BIRD 日時: 13:21 | パーマリンク | コメント (0) | トラックバック (0)