[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ドット絵変換を楽にしたい。』（ひろりん）
お世話になります。
手芸の好きな方から写真をドット絵に変換してビーズの配列を作りたいとの相談を受け
渡されたのが下記のコードです。
会社では、マクロの記録で帳票出力の改善する程度なので正直分りません。
彼女が言うにはフォルダ内の写真をドット絵にしたいそうなので Sheet1のB3に拡張子も
含めた写真のパスを入れ、Sheet2にドット絵が出る様にしたいと言っていました。
何をどういじくって良いかわからず、丸投げで恐縮ですが、宜しくお願い致します。
Option Explicit
'画像ファイルをシート上に展開するプログラム
Sub bitmap()
Dim filename As String 'ファイル名
filename = ThisWorkbook.Path + "\00002.bmp" '読み込むファイル
Dim ff As Long 'フリーファイル
ff = FreeFile 'フリーファイル変数
Dim databuf() As Byte 'バイト配列
Open filename For Binary As #ff 'バイナリモードでファイルを開く
ReDim databuf(LOF(ff)) 'バイト配列のサイズをセット
Get #ff, 1, databuf 'バイト配列にデータを格納
Close #ff
'=====================================================================================
Dim image_power As Long '画像の倍率
'=====================================================================================
image_power = 2 '倍率を1/image_powerで指定
'=====================================================================================
Dim bmp_width As Long '画像の横サイズ
bmp_width = HexToDec(databuf, 18, 21) '4バイト
Dim bmp_height As Long '画像の縦サイズ
bmp_height = HexToDec(databuf, 22, 25) '4バイト
Dim bmp_bit As Integer '画像のビットサイズ
bmp_bit = HexToDec(databuf, 28, 29) '2バイト
Dim file_size As Long 'ファイルサイズ
file_size = HexToDec(databuf, 2, 5) '4バイト
Cells.Clear 'セルをクリア
Range(Columns(1), Columns(bmp_width / image_power)).ColumnWidth = 0.31 'セルの横幅
Range(Rows(1), Rows(bmp_height / image_power)).RowHeight = 3 'セルの縦幅
Dim width_size As Long 'セル上の横サイズ
width_size = Fix(bmp_width / image_power)
Dim height_size As Long 'セル上の縦サイズ
height_size = Fix(bmp_height / image_power)
If height_size = 0 Then
MsgBox "指定した倍率が小さすぎます", vbExclamation
Exit Sub '高さが0になる場合、終了
End If
'=====================================================================================
'倍率を考慮して補正するバイト数を調整
'=====================================================================================
Dim widthcount As Long '横のデータ数
Dim addpos As Integer '埋めるバイト数
widthcount = Fix(bmp_width * 3)
If widthcount Mod 4 > 0 Then '※widthが4の倍数に満たない場合、横の実データ数を求める
widthcount = Fix(widthcount / 4 + 1) * 4
'例
'widthcount = 192 * 3 = 576 → widthcount Mod 4 = 0バイト埋める → 1列 = 576バイト
'widthcount = 191 * 3 = 573 → widthcount Mod 4 = 3バイト埋める → 1列 = 576バイト
'widthcount = 190 * 3 = 570 → widthcount Mod 4 = 2バイト埋める → 1列 = 572バイト
'widthcount = 189 * 3 = 567 → widthcount Mod 4 = 1バイト埋める → 1列 = 568バイト
End If
addpos = widthcount - width_size * image_power * 3 '倍率に応じた不足分を調整
'=====================================================================================
Dim pos As Long 'データオフセット
Dim w_index As Long 'ビットマップの横位置
Dim h_index As Long 'ビットマップの縦位置
w_index = 1 '横の初期位置座標(左)をセット
h_index = height_size '縦の初期位置座標(下)をセット
pos = 54 '初期値(データ先頭位置)
For h_index = h_index To 1 Step -1 '高さのループ
For w_index = 1 To width_size '幅のループ
Cells(h_index, w_index).Interior.Color = _
RGB(HexToDec(databuf, pos + 2, pos + 2), _
HexToDec(databuf, pos + 1, pos + 1), _
HexToDec(databuf, pos, pos)) 'データに対応するセル背景色にRGBを指定
pos = pos + 3 * image_power '横移動
Next
pos = pos + addpos '4バイト区切りの不足分を加算(posを調整)
pos = pos + widthcount * (image_power - 1) '列×倍率分飛ばす(縦移動)
Next
MsgBox "画像の展開が完了しました" '処理完了
End Sub
'連続したバイト配列の値を10進数に変換する関数
Function HexToDec(ByRef databuf, first, last) As Long
Dim i As Long 'ループカウンタ
Dim temp As String '16進数を格納する文字列配列
temp = ""
For i = last To first Step -1 '後ろから処理
temp = temp + Right("00" & Hex(databuf(i)), 2) '10進数を16進数に変換
Next
HexToDec = Val("&H" & temp) '16進数を10進数に変換
End Function
＜ 使用 Excel：Excel2007、使用 OS：Windows7 ＞
VBAは上記のリンク先のもののようだ。
なぜ依頼者に「私のレベルでは無理」と断らないのだろう？ （ねむねむ） 2016/05/10(火) 14:22
＞ filename = ThisWorkbook.Path + "\00002.bmp" '読み込むファイル
それを下の２文に変えるだけじゃないですか？ 当方でテストはしておりません <(_ _)>
Filename = ThisWorkbook.Sheets("Sheet1").Range("B3").Value '読み込むファイル
ThisWorkbook.Sheets("Sheet2").Select
（半平太） 2016/05/10(火) 14:32
ねむねむさんと同じ感想を持ちました。 というか、その依頼した人も、このコードを見つけるぐらいなら、それを元に自分でできないのでしょうか？ できないので、ひろりんさんに相談したということは、その人から見て、ひろりんさんは、ＶＢＡの達人で 頼めば何とかなると そう思ったんでしょうね。
で、ひろりんさんは？ 【まかしといて！ かんたんだよ〜！】とでも答えたんですかね？
ちなみに、バージョンによって制限値は異なってくると思いますが、xl2013の場合、 新規ブックで、以下のコードを走らせると 65430個目の書式設定で、エラーになりますね。
Sub test()
Dim i As Long
On Error GoTo bye
For i = 1 To 100000
Cells(i, 1).Interior.Color = i
Next
bye:
MsgBox i
End Sub
★世の中にはフリーソフトでドット絵を描くものがたくさんでまわっているようです。 なぜ、そういったものを使わないのでしょうか？
（β） 2016/05/10(火) 16:26
Sub test()
Const IMAGE_POWER = 2
Dim filename As String
Dim ff As Integer
Dim databuf() As Byte
Dim file_size As Long
Dim data_offset As Long
Dim bmp_width As Long
Dim bmp_height As Long
Dim bmp_bit As Integer
Dim widthcount As Long
Dim i As Long
Dim j As Long
Dim i2 As Long
Dim j2 As Long
Dim iR As Long
Dim iG As Long
Dim iB As Long
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "BMPファイル", "*.bmp"
.InitialView = msoFileDialogViewLargeIcons
If Not .Show Then Exit Sub
filename = .SelectedItems(1)
End With
ff = FreeFile
Open filename For Binary As #ff
Get #ff, 3, file_size
Get #ff, 11, data_offset
Get #ff, 19, bmp_width
Get #ff, 23, bmp_height
Get #ff, 29, bmp_bit
ReDim databuf(file_size - data_offset - 1)
Get #ff, data_offset + 1, databuf
Close #ff
If bmp_bit <> 24 Then
MsgBox bmp_bit & "bitカラーには対応していません。", vbCritical, "色数エラー"
End
End If
widthcount = Int((bmp_width + 3) / 4) * 4
With Sheets(1)
.Cells.Clear
With .Range("A1").Resize(bmp_height / IMAGE_POWER, bmp_width / IMAGE_POWER)
.ColumnWidth = 0.3
.RowHeight = 2.5
End With
Application.ScreenUpdating = False
For i = 0 To bmp_height - 1 Step IMAGE_POWER
For j = 0 To widthcount - 1 Step IMAGE_POWER
iR = 0
iG = 0
iB = 0
For i2 = 0 To IMAGE_POWER - 1
For j2 = 0 To IMAGE_POWER - 1
iB = iB + databuf((i + i2) * widthcount * 3 + (j + j2) * 3 + 0)
iG = iG + databuf((i + i2) * widthcount * 3 + (j + j2) * 3 + 1)
iR = iR + databuf((i + i2) * widthcount * 3 + (j + j2) * 3 + 2)
Next j2
Next i2
iR = iR / IMAGE_POWER / IMAGE_POWER
iG = iG / IMAGE_POWER / IMAGE_POWER
iB = iB / IMAGE_POWER / IMAGE_POWER
.Cells((bmp_height - i) / IMAGE_POWER, j / IMAGE_POWER + 1).Interior.Color = RGB(iR, iG, iB)
Next j
Next i
Application.ScreenUpdating = True
End With
MsgBox "画像の展開が完了しました", vbInformation, "処理終了"
End Sub
こういうロジックは、自分で作って動かすところが面白いのですけどねぇ。
（???） 2016/05/10(火) 17:30
であればフリーソフトを教えてあげれば、もっと喜ばれるかもしれませんよ。 ところで、こんなコードもありました。
http://i-break.net/article/68821422.html
（β） 2016/05/10(火) 22:04
目的がビーズ細工との事なので、使えるビーズの色数は限りがあるかと思います。
また、今回のマクロでは、フルカラーでセルを塗るだけなので、セル毎にどんなRGB値なのか調べていくのはかなり面倒ではないかと思います。
つまり、フルカラーのままでは使い物にならないのではないか、と。
欲しいのは、予めビーズ番号とRGBを列挙しておくと、セル毎に最も近い色のビーズ番号を表示してくれるような機能ではないかと思います。
これを実現するには、今回のロジックだけでは足りず、特定の色に合わせた減色機能が必要になり、市販アプリ作成並の難易度になります。
専務さんにこれを作れ、と言われたら、どうするのでしょうね？
安上がりな案としては、GIMPのようなフリーの画像編集アプリを利用し、ビーズ種類分の色パレット作成。256色に減色（使うパレット数はビーズ種類分だけ）まで実現する事。
そして、Excel側はパレット付き8bitカラーに対応させ、色塗りだけでなく、番号表示も行う事です。
（???） 2016/05/11(水) 09:24
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.