忙しい現代人の腰&肩のお悩み対策!

http://oshiete.goo.ne.jp/qa/8858627.html


このページでVBAのGDI+を使った8bitや24bitの画像の取扱方にについて教えていただきました。

追加の質問なのですが
画像を読み込んで画像のビット数を調べるにはどうしたら良いですか?
8bitなのか24bitなのか?


それと読み込んだ画像のdpiを取得する方法および
dpiを設定して画像を保存するにはどうしたら良いですか?

検索して調べてみましたが見つかりませんでしたので
ご助言いただけないでしょうか?

 

このQ&Aに関連する最新のQ&A

A 回答 (4件)

#1です。


下記をお試し下さい。
Public Declare Function GdipGetImageHorizontalResolution Lib "gdiplus" (ByVal Image As Long, resolution As Single) As Long
Public Declare Function GdipGetImageVerticalResolution Lib "gdiplus" (ByVal Image As Long, resolution As Single) As Long

こちらは簡単ではなさそうな気がします。当方の良く分かっていないGDI+のGraphicsがからんできそうな気配が...
Public Declare Function GdipBitmapSetResolution Lib "gdiplus" (ByVal bitmap As Long, ByVal xdpi As Single, ByVal ydpi As Single) As Long
以上、ご参考まで。
    • good
    • 0

#3の構造体、API宣言等です。


Public Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type

Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

Public Type EncoderParameter
GUID As GUID
NumberOfValues As Long
Type As Long
Value As Long
End Type

Public Type EncoderParameters
Count As Long
Parameter(15) As EncoderParameter
End Type

Public Const CLSID_JPEG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Public Const CLSID_QUALITY As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

Public Declare Function GdipCreateBitmapFromFile Lib "gdiplus" _
(FileName As Any, bitmap As Long) As Long
Public Declare Function GdipCreateBitmapFromGraphics Lib "gdiplus" _
(ByVal Width As Long, ByVal Height As Long, _
ByVal Target As Long, bitmap As Long) As Long
Public Declare Function GdipDeleteGraphics Lib "gdiplus" _
(ByVal graphics As Long) As Long
Public Declare Function GdipDisposeImage Lib "gdiplus" _
(ByVal image As Long) As Long
Public Declare Function GdipDrawImageRectI Lib "gdiplus" _
(ByVal graphics As Long, ByVal image As Long, _
ByVal x As Long, ByVal y As Long, _
ByVal Width As Long, ByVal Height As Long) As Long
Public Declare Function GdipGetImageGraphicsContext Lib "gdiplus" _
(ByVal image As Long, graphics As Long) As Long
Public Declare Function GdipGetImageHeight Lib "gdiplus" _
(ByVal image As Long, Height As Long) As Long
Public Declare Function GdipGetImageWidth Lib "gdiplus" _
(ByVal image As Long, Width As Long) As Long
Public Declare Function GdipSaveImageToFile Lib "gdiplus" ( _
ByVal image As Long, _
ByVal FileName As Long, _
ByRef clsidEncoder As GUID, _
ByVal encoderParams As Any) As Long
Public Declare Sub GdiplusShutdown Lib "gdiplus" _
(ByVal token As Long)
Public Declare Function GdiplusStartup Lib "gdiplus" _
(token As Long, pInput As GdiplusStartupInput, _
pOutput As Any) As Long
Public Declare Function GdipBitmapSetResolution Lib "gdiplus" (ByVal bitmap As Long, ByVal xdpi As Single, ByVal ydpi As Single) As Long
Public Declare Function CLSIDFromString Lib "ole32.dll" ( _
ByVal lpszCLSID As Long, _
ByRef pCLSID As GUID) As Long
    • good
    • 0
この回答へのお礼

何から何までありがとうございます。

 

お礼日時:2015/01/10 18:42

mitarashiです。

昔某所で教わった画像リサイズのコードを改変すると、一応dpiの変更が出来た様です。但し、Indexed画像はGraphicsが生成出来ないそうで対象になりません。
構造体、APIのDeclare等は別途投稿します。

Sub changeDpi()
Dim IID_IDispatch As GUID
Dim udtInput As GdiplusStartupInput
Dim lngToken As Long, lngStatus As Long
Dim pGraphics As Long
Dim pSrcBmp As Long, pDstBmp As Long
Dim lngWidth As Long, lngHeight As Long
Dim EncodParameters As EncoderParameters
Dim srcPath As String, dstPath As String
Const jpegQuality As Long = 90
Const myDpi As Long = 300

srcPath = GetDesktopPath & "\sample1.jpg"
dstPath = GetDesktopPath & "\sample2.jpg"

' 初期化
udtInput.GdiplusVersion = 1
If GdiplusStartup(lngToken, udtInput, ByVal 0&) <> 0 Then
Exit Sub
End If

' 画像の読みこみ
If GdipCreateBitmapFromFile(ByVal StrPtr(srcPath), pSrcBmp) <> 0 Then
GdiplusShutdown lngToken
Exit Sub
End If

' 元画像サイズの取得
GdipGetImageWidth pSrcBmp, lngWidth
GdipGetImageHeight pSrcBmp, lngHeight

If GdipGetImageGraphicsContext(pSrcBmp, pGraphics) = 0 Then
' コピー先Bitmap作成
lngStatus = GdipCreateBitmapFromGraphics( _
lngWidth, lngHeight, pGraphics, pDstBmp)
'dpiの指定
lngStatus = GdipBitmapSetResolution(pDstBmp, myDpi, myDpi)
GdipDeleteGraphics pGraphics
If lngStatus = 0 Then
' コピー用Graphics作成
If GdipGetImageGraphicsContext(pDstBmp, pGraphics) = 0 Then
' イメージのコピー
GdipDrawImageRectI pGraphics, pSrcBmp, 0, 0, lngWidth, lngHeight
GdipDeleteGraphics pGraphics
' エンコーダパラメータ設定
EncodParameters.Count = 1
With EncodParameters.Parameter(0)
.GUID = ConvCLSID(CLSID_QUALITY)
.NumberOfValues = 1
' 4=EncoderParameterValueTypeLong
.Type = 4
' 圧縮品質
.Value = VarPtr(jpegQuality)
End With
' JPG変換で保存
Call GdipSaveImageToFile(pDstBmp, StrPtr(dstPath), ConvCLSID(CLSID_JPEG), VarPtr(EncodParameters))
End If
GdipDisposeImage pDstBmp
End If
End If
GdipDisposeImage pSrcBmp
GdiplusShutdown lngToken
End Sub

Private Function ConvCLSID(ByVal sGuid As String) As GUID
CLSIDFromString StrPtr(sGuid), ConvCLSID
End Function

GraphicsというのはGDI+のキャンバスの様な物で、拡大縮小回転、描画といった操作はこの上で行う必要があるそうです。.NETの説明ですが、ご参考まで。
http://msdn.microsoft.com/ja-jp/library/5y289054 …
「GDI+を使ったビット数とDPIの扱い」の回答画像3
    • good
    • 0

こちらでそれらしい関数を探してみて下さい。


https://github.com/javiercrowsoft/cairo-vb6/blob …

本家のこちらもご参考になるでしょう。
http://msdn.microsoft.com/en-us/library/ms533969(v=vs.85).aspx

色深度については、GdipGetImagePixelFormatを検索してみつかった下記コードで、8bitIndexedのBMPについては、"&H" & Hex(Depth) -> PixelFormat8bppIndexed = &H30803が得られました。透明が入っていると所期の結果にならないとあり、返事ももらえていない様ですが...
http://www.vbforums.com/showthread.php?718163-GD …

以上、とりあえずご参考まで。

この回答への補足

間違いました

宣言する関数は

Private Declare Function GdipGetDpiX Lib "gdiplus" (ByVal graphics As Long, dpi As Single) As Long

です。

これでうまくいかないのですがなぜでしょうか?
 

補足日時:2015/01/06 15:23
    • good
    • 0
この回答へのお礼

毎度毎度、ご回答ありがとうございます。

GdipGetImagePixelFormatの方はうまくいきました。

dpiの取得の方なのですが



Private Declare Function GdipGetImagePixelFormat Lib "gdiplus.dll" ( _
ByVal pImage As Long, _
ByRef pFormat As Long) As Long

を宣言して


Call GdipGetDpiX(hBmp, dpi_x)

で取得を試みたのですが
dpi_xの値は0になってしまいます。

どうすれば良いでしょうか?

お礼日時:2015/01/06 15:22

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Q画像のビット数を変更する方法

http://oshiete.goo.ne.jp/qa/8880161.html

このページなどで画像の取扱に関して詳しく教えていただきました。

大体、思ったことはできるようになったのですが
まだ疑問点が残っております。

例えば、24bit画像をGDI+で読み込んで、
アルファチャンネルに情報を書き加えた後、
そのまま画像を出力します。

するとirfanviewなどで読み込んだ際に
アルファチャンネルに情報をもっているにも拘わらず
24bit画像をとして認識されてしまいます。

アルファチャンネルをもっているかいないかではなく
画像のインデックスのところに24か32bitかを識別するものが含まれているようです。


読み込んだ24bit画像を32bit画像に変換したいのですが
どのようにすれば良いでしょうか?

GdipCreateBitmapFromScan0(lngWidth, lngHeight, 0, PixelFormat32bppARGB, ByVal 0&, hBmp2)

を使えば、32bit画像を生成できますが
新たにbitmapオブジェクトを生成せずに
読み込んだオブジェクトのbit数を変更する方法を教えてください。

http://oshiete.goo.ne.jp/qa/8880161.html

このページなどで画像の取扱に関して詳しく教えていただきました。

大体、思ったことはできるようになったのですが
まだ疑問点が残っております。

例えば、24bit画像をGDI+で読み込んで、
アルファチャンネルに情報を書き加えた後、
そのまま画像を出力します。

するとirfanviewなどで読み込んだ際に
アルファチャンネルに情報をもっているにも拘わらず
24bit画像をとして認識されてしまいます。

アルファチャンネルをもっているかいないかではなく
画像のインデッ...続きを読む

Aベストアンサー

mitarashiです。シリーズで回答させていただきながら、当方も勉強してきましたが、そろそろ追い越されそうな雰囲気ですね。お望みの事は分かりかねます。検索して見つかるのは、32bitカラーのGraphicsを質問文中にもあるGdipCreateBitmapFromScan0で作成した32bitのbitmapから作成する方法です。
myumyu1234さんが行われているのは、個々のPixelの透明度の変更の様なので、GdipBitmapLockBitsをお使いなのでしょうか。
回答にはなっておりませんが、前回のhttp://oshiete.goo.ne.jp/qa/8880161.htmlへの回答のコードがどうも分かり難いと思っていましたが、どうやら冗長らしいので、その部分を修正し、24->32bitへの変更も盛り込んだコードを投稿させていただきます。
なお、32bitをサポートしているPNGでの保存に変更しています。

構造体、API宣言は、下記が追加になります。
Public Const CLSID_PNG As String = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Public Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal graphics As Long, ByVal lColor As Long) As Long

Sub test()
Dim IID_IDispatch As GUID
Dim udtInput As GdiplusStartupInput
Dim lngToken As Long, lngStatus As Long
Dim pGraphics As Long
Dim pSrcBmp As Long, pDstBmp As Long
Dim lngWidth As Long, lngHeight As Long
Dim srcPath As String, dstPath As String
Const myDpi As Long = 300

srcPath = GetDesktopPath & "\sample1.jpg"
dstPath = GetDesktopPath & "\sample2.png"

' 初期化
udtInput.GdiplusVersion = 1
If GdiplusStartup(lngToken, udtInput, ByVal 0&) <> 0 Then
Exit Sub
End If

' 画像の読みこみ
If GdipCreateBitmapFromFile(ByVal StrPtr(srcPath), pSrcBmp) <> 0 Then
GdiplusShutdown lngToken
Exit Sub
End If

' 元画像サイズの取得
GdipGetImageWidth pSrcBmp, lngWidth
GdipGetImageHeight pSrcBmp, lngHeight
' コピー先Bitmap作成
lngStatus = GdipCreateBitmapFromScan0(lngWidth, lngHeight, 0, PixelFormat32bppARGB, ByVal 0&, pDstBmp)
'dpiの指定
lngStatus = GdipBitmapSetResolution(pDstBmp, myDpi, myDpi)
If lngStatus = 0 Then
' コピー用Graphics作成
If GdipGetImageGraphicsContext(pDstBmp, pGraphics) = 0 Then
'白で初期化(検索してみつかったコードは大抵含んでいたので追加)
GdipGraphicsClear pGraphics, &HFFFFFFFF
' イメージのコピー
GdipDrawImageRectI pGraphics, pSrcBmp, 0, 0, lngWidth, lngHeight
'Graphicsの始末
GdipDeleteGraphics pGraphics
'PNGで保存
Call GdipSaveImageToFile(pDstBmp, StrPtr(dstPath), ConvCLSID(CLSID_PNG), ByVal 0&)
End If
GdipDisposeImage pDstBmp
End If
GdipDisposeImage pSrcBmp
GdiplusShutdown lngToken
End Sub

mitarashiです。シリーズで回答させていただきながら、当方も勉強してきましたが、そろそろ追い越されそうな雰囲気ですね。お望みの事は分かりかねます。検索して見つかるのは、32bitカラーのGraphicsを質問文中にもあるGdipCreateBitmapFromScan0で作成した32bitのbitmapから作成する方法です。
myumyu1234さんが行われているのは、個々のPixelの透明度の変更の様なので、GdipBitmapLockBitsをお使いなのでしょうか。
回答にはなっておりませんが、前回のhttp://oshiete.goo.ne.jp/qa/8880161.htmlへの回答のコー...続きを読む

Q8bitインデックス画像の入出力方法

http://oshiete.goo.ne.jp/qa/8852322.html
http://oshiete.goo.ne.jp/qa/8856128.html


このページで画像の配列への入出力の仕方を教えていただきました。

配列の読み書きの方法が分かればできるかと思ったのですが
やり方がわかりませんでしたので質問いたします。

24あるいは32bitの場合には教えていただいた方法で問題ないのですが
8bitの画像(インデックスカラー画像)の場合にはどうしたら良いでしょうか?

8bit画像を

GdipCreateBitmapFromFile(ByVal StrPtr(strInName), pSrcBitmap)

で取得し、そのまま

GdipSaveImageToFile pSrcBitmap, StrPtr(strOutName), encTIFF, VarPtr(udtEncParam)

を使って、別の画像形式に再圧縮して出力しても
8bit画像として出力されるので、
pSrcBitmapにはインデックスカラーに関する情報と
256階調(8bit)での画像情報も含まれているようです。

しかしながら、

GdipBitmapGetPixel pSrcBitmap, x, y, myARGB

で画像情報を抽出すると
8bit画像を読み込んだとしても
32bitカラー情報として抽出されてしまいます。


http://www.vbforums.com/showthread.php?718163-GDI-GdipGetImagePixelFormat-(untrusted)

このサイトにPixelFormatの設定の仕方が書かれてあって、
PixelFormat24bppRGB = &H21808
を用いると24bit画像として出力できることが分かりました。

PixelFormat8bppIndexed = &H30803
を指定してみたのですが、
一応、8bit画像として出力することは確認できたのですが
出力にものすごく時間がかかってしまうのですが。

恐らくインデックスを生成するのに時間がかかっているのだと思うのですが
既にインデックスがでている場合にどのように指定すれば良いか、
8bit画像からインデックスを抽出するのかが分からないのですが。




どのようにすれば
インデックスカラーと256階調(8bit)での画像情報を
配列に読み込み、および配列から画像への書き出しを行えますでしょうか?

http://oshiete.goo.ne.jp/qa/8852322.html
http://oshiete.goo.ne.jp/qa/8856128.html


このページで画像の配列への入出力の仕方を教えていただきました。

配列の読み書きの方法が分かればできるかと思ったのですが
やり方がわかりませんでしたので質問いたします。

24あるいは32bitの場合には教えていただいた方法で問題ないのですが
8bitの画像(インデックスカラー画像)の場合にはどうしたら良いでしょうか?

8bit画像を

GdipCreateBitmapFromFile(ByVal StrPtr(strInName), pSrcBitmap)

で取得し、...続きを読む

Aベストアンサー

mitarashiです。ひょっとしてこういう事がご希望だったのでしょうか?新規作成をやってみました。ご参考まで。
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus.dll" (ByVal nWidth As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, nBitmap As Long) As Long

Sub make8bitIndexedBitmap()
Dim GDIsi As GdiplusStartupInput, gToken As Long, pBitmap As Long
Dim bmpData As BitmapData
Dim lrect As RECT
Dim x As Long, y As Long
Dim lWidth As Single, lHeight As Single
Dim buf(0) As Byte
Dim strOutName As String
Dim encBMP As UUID
Dim paletteSize As Long
Dim palette As ColorPalette
Dim i As Long
Dim strBGR As String
Dim myARGB As Long

GDIsi.GdiplusVersion = 1&
GdiplusStartup gToken, GDIsi

lWidth = 200: lHeight = 100
Call GdipCreateBitmapFromScan0(lWidth, lHeight, 0, PixelFormat8bppIndexed, ByVal 0&, pBitmap)

lrect.Top = 0: lrect.Left = 0
lrect.Bottom = CLng(lHeight): lrect.Right = CLng(lWidth)

If GdipBitmapLockBits(pBitmap, lrect, ImageLockMode.ReadWrite, PixelFormat8bppIndexed, bmpData) <> 0 Then
Exit Sub
End If

For x = 0 To lWidth - 1
For y = 0 To lHeight - 1
buf(0) = y \ 10
MoveMemory ByVal bmpData.scan0 + (y * bmpData.stride) + x, buf(0), 1
Next y
Next x
Call GdipBitmapUnlockBits(pBitmap, bmpData)

'Palette設定
Call GdipGetImagePaletteSize(pBitmap, paletteSize)
Call GdipGetImagePalette(pBitmap, palette, paletteSize)
'Range("A1:P16")のセルの色からPaletteの色を設定する
For i = 0 To 255
strBGR = Hex(ActiveSheet.Cells((i \ 16) + 1, (i Mod 16) + 1).Interior.Color)
strBGR = Right("000000" & strBGR, 6)
myARGB = CLng("&H" & "FF" & Mid(strBGR, 5, 2) & Mid(strBGR, 3, 2) & Mid(strBGR, 1, 2))
palette.Entries(i) = myARGB
Next i
Call GdipSetImagePalette(pBitmap, palette)

'BMP保存
strOutName = GetDesktopPath & "\make8bitIndexed.bmp"
CLSIDFromString StrPtr("{557CF400-1A04-11D3-9A73-0000F81EF32E}"), encBMP
Call GdipSaveImageToFile(pBitmap, StrPtr(strOutName), encBMP, ByVal 0&)

GdipDisposeImage pBitmap
GdiplusShutdown gToken
End Sub

mitarashiです。ひょっとしてこういう事がご希望だったのでしょうか?新規作成をやってみました。ご参考まで。
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus.dll" (ByVal nWidth As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, nBitmap As Long) As Long

Sub make8bitIndexedBitmap()
Dim GDIsi As GdiplusStartupInput, gToken As Long, pBitmap As Long
Dim bmpData As BitmapData
Dim lrect As RECT
Dim x As Long, y As Long...続きを読む

Qbmp画像をjpegやpng画像に圧縮する方法

http://oshiete.goo.ne.jp/qa/8809275.html

このページでbmp画像をtiff圧縮する方法を教えていただきました。


このプログラムを改良して
jpegやpng画像にも対応したプログラムを作ることはできないでしょうか?

恐らく、

   CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .Guid ' 圧縮方法

というところを書き換えれば、他の形式にも対応できると思うのですが、
CLSIDFromString で検索しても、情報は見つかりませんでした。

どうか教えてください。

Aベストアンサー

#1,2です。KenKen_SP様には失礼して、改造部分のコードを提示させていただきます。Win7Home(64) xl2010(32) で試しています。
出典:http://oshiete.goo.ne.jp/qa/5124395.html

' // Bitmapオブジェクトからファイルへ書き出し
Public Function SaveImageToFile( _
ByVal hBmp As OLE_HANDLE, _
ByVal sFilename As String, _
Optional ByVal sFormat As String = "JPG", _
Optional ByVal nQuarity As Long = 60 _
) As Boolean

'@ sFormat : BMP, JPG, GIF, TIF, PNG
'@ nQuality: 0-100(0:高圧縮低画質, 100:低圧縮高画質, Jpg のみ有効)

Dim sEncoderStr As String
Dim nStatus As Long

Select Case UCase$(sFormat)
Case "JPG": sEncoderStr = ENCODER_JPG
Case "GIF": sEncoderStr = ENCODER_GIF
Case "TIF": sEncoderStr = ENCODER_TIF
Case "PNG": sEncoderStr = ENCODER_PNG
Case Else: sEncoderStr = ENCODER_BMP
End Select

Dim uEncoderParams As EncoderParameters
' Jpeg のクオリティー設定
If UCase$(sFormat) = "JPG" Then
nQuarity = Abs(nQuarity)
If nQuarity > 100 Then nQuarity = 100
uEncoderParams.count = 1
With uEncoderParams.Parameter(0)
.GUID = pvToCLSID(QUALITY_PARAMS)
.TypeAPI = 4 ' Type Long
.Value = VarPtr(nQuarity)
.NumberOfValues = 1
End With
End If

' 保存処理
If UCase$(sFormat) = "JPG" Then
nStatus = GdipSaveImageToFile(hBmp, _
StrPtr(sFilename), _
pvToCLSID(sEncoderStr), _
VarPtr(uEncoderParams))
Else
nStatus = GdipSaveImageToFile(hBmp, _
StrPtr(sFilename), _
pvToCLSID(sEncoderStr), _
ByVal 0&)
End If
SaveImageToFile = CBool(nStatus = 0)
Call GdipDisposeImage(hBmp)

End Function

' // サンプル
Sub Sample()
Dim hBmp As OLE_HANDLE
Dim file1 As String

file1 = GetDesktopPath & "\Hydrangeas.bmp"
' GDI+ を初期化する
If GDIplus_Initialize() = False Then
MsgBox "GDI+ を初期化できません", vbCritical
Exit Sub
End If
'変換元ファイル読込
If GdipCreateBitmapFromFile(ByVal StrPtr(file1), hBmp) <> 0 Then
Gdiplus_Shutdown
Exit Sub
End If

' 保存(JPEG でクオリティー30の場合)
If SaveImageToFile(hBmp, GetDesktopPath & "\sample.jpg", "jpg", 30) = False Then
MsgBox "保存に失敗", vbCritical
Else
MsgBox "保存に成功", vbInformation
End If
' GDI+ を終了させる(必ず呼び出すこと)
Call Gdiplus_Shutdown
End Sub

'テスト用
Private Function GetDesktopPath() As String
Dim wScriptHost As Object, strInitDir As String
Set wScriptHost = CreateObject("Wscript.Shell")
GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
Set wScriptHost = Nothing
End Function

#1,2です。KenKen_SP様には失礼して、改造部分のコードを提示させていただきます。Win7Home(64) xl2010(32) で試しています。
出典:http://oshiete.goo.ne.jp/qa/5124395.html

' // Bitmapオブジェクトからファイルへ書き出し
Public Function SaveImageToFile( _
ByVal hBmp As OLE_HANDLE, _
ByVal sFilename As String, _
Optional ByVal sFormat As String = "JPG", _
Optional ByVal nQuarity As Long = 60 _
) As Boolean

'@ sFormat : BMP, JPG, GIF, TIF, PNG
'@ nQuality: 0-...続きを読む

Qファイルをメモリに出力する方法

ある配列をtiff画像ファイルとして出力したいのですが

配列を一度bmp画像ファイルとして出力して

http://oshiete.goo.ne.jp/qa/8809275.html

このページにある方法を使って、それをtiffファイルに変換して
残ったbmpファイルを削除するというプログラムを作りました。

この方法だと、HDDにアクセスする手順が多くなるため、ファイル数が多い時に時間がかかってしまいます。

bmpファイルをメモリにいったん保存しておいて、
それをtiffファイルに書き換えるようなプログラムを作るにはどうしたら良いですか?

あるいは配列から直接tiff画像ファイルを出力する方法があれば
教えてください。

Aベストアンサー

#1-3です。
型変換をVBAに頼り過ぎだと存じます。
真面目にやるべきでしょう。
簡単な例で試してみました。ご参考まで。

Sub test()
Dim myR As Byte, myG As Byte, myB As Byte
Dim myRGB As Long
myR = 255
myG = 255
myB = 255
myRGB = myR & myG & myB
Debug.Print Hex(myRGB) '->F36E2D7 白にならない
End Sub

Sub test2()
Dim myR As Byte, myG As Byte, myB As Byte
Dim myRGB As Long
myR = 255
myG = 255
myB = 255
myRGB = CLng("&H" & Hex(myR) & Hex(myG) & Hex(myB))
Debug.Print Hex(myRGB) '-> FFFFFF
End Sub

Sub test3()
Dim myR As Long, myG As Long, myB As Long 'Byte型だとmyR * &H10000のところでオーバーフロー
Dim myRGB As Long
myR = 255
myG = 255
myB = 255
myRGB = myR * &H10000 + myG * &H100 + myB
Debug.Print Hex(myRGB) '->FFFFFF
End Sub

#1-3です。
型変換をVBAに頼り過ぎだと存じます。
真面目にやるべきでしょう。
簡単な例で試してみました。ご参考まで。

Sub test()
Dim myR As Byte, myG As Byte, myB As Byte
Dim myRGB As Long
myR = 255
myG = 255
myB = 255
myRGB = myR & myG & myB
Debug.Print Hex(myRGB) '->F36E2D7 白にならない
End Sub

Sub test2()
Dim myR As Byte, myG As Byte, myB As Byte
Dim myRGB As Long
myR = 255
myG = 255
myB = 255
myRGB = CLng("&H" & Hex(myR) & Hex(myG) & Hex(myB))
...続きを読む

Qbmp画像をtiff圧縮する方法

VBAを使って、bmp画像をtiff圧縮するプログラムを教えてください。

検索すると

http://oshiete.goo.ne.jp/qa/8508126.html

画像圧縮、変換用のライブラリ を使えば良いという回答ページは見つかったのですが
具体的な方法が分かりません。

「画像 dll vba tif bmp」などで検索してみても分かりませんでしたので
教えてください。

Aベストアンサー

こちらはいかがでしょうか。
http://tanlab.blog.fc2.com/blog-entry-31.html

試してみたところ、ファイル名は、変数に変えてもOKでした。
Dim file1 As String, file2 As String

file1 = "C:\Users\Public\Pictures\Sample Pictures\Hydrangeas.jpg"
file2 = getDeskTopPath & "\test.tif"
(注)getDeskTopPathはデスクトップのパスを取得する自作(というかWebから切り貼りした)関数

GdipCreateBitmapFromFileは、BMP,JPEG,PNG,TIFF等に対応しています。

With encParam.Parameter(0)
    .Value = VarPtr(4) ' 画像圧縮:LZW=2, CCITT3=3, CCITT4=4, Rle=5, None=6
End With
圧縮方法については詳しくは無いですがVarPtr(2)のLZW等にするとカラーになりました。
なお、JPEGからLZW圧縮TIFFに変換したら巨大ファイルになりました。当たり前かも。

こちらはいかがでしょうか。
http://tanlab.blog.fc2.com/blog-entry-31.html

試してみたところ、ファイル名は、変数に変えてもOKでした。
Dim file1 As String, file2 As String

file1 = "C:\Users\Public\Pictures\Sample Pictures\Hydrangeas.jpg"
file2 = getDeskTopPath & "\test.tif"
(注)getDeskTopPathはデスクトップのパスを取得する自作(というかWebから切り貼りした)関数

GdipCreateBitmapFromFileは、BMP,JPEG,PNG,TIFF等に対応しています。

With encParam.Parameter(0)
 ...続きを読む

QExcelのVBAで画像読込→サイズ変更がしたい。

Excel2003を利用して仕事の工事写真帳を作成していますがVBAでどうしても上手くいかない部分があるので教えていただければと思い投稿しました。
【仕様】工事写真帳は1シート構成、用紙1枚に3枚画像が入り、画像の右側には摘要欄があります。画像を読み込む位置をダブルクリックするとセルのサイズ(写真サイズに結合してあります)を取得して画像サイズを変更して格納します。
【問題点】2枚以上画像を読み込んだ状態で実行すると目的の画像のサイズが変更にならない場合があります。
画像を削除したことで画像の名前が重複するのが原因だというところまではわかるのですが対処方法がわかりません。アドバイスをお願いします。

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

gyo = ActiveCell.Row '画像読込位置の取得
Set scel = Cells(gyo, 3)

scel.Select 'セルサイズの取得
w = Selection.Width
h = Selection.Height

fname = Application.GetOpenFilename _
("画像ファイル,*.gif;*.jpg;*.bmp", 1, "画像ファイルを指定して下さい") '画像読込
If fname = False Then
Exit Sub
End If
ActiveSheet.Pictures.Insert(fname).Select
i% = Selection.Index


Selection.Name = "gazou" & i '画像に名前をつける
Set 画像 = ActiveSheet.Shapes("gazou" & i)


With 画像 '画像のサイズ変更
.LockAspectRatio = False
.Placement = xlFreeFloating
.Placement = xlMove
.Width = w
.Height = h
End With

Range("F" & gyo).Select '摘要欄へ移動

End Sub

Excel2003を利用して仕事の工事写真帳を作成していますがVBAでどうしても上手くいかない部分があるので教えていただければと思い投稿しました。
【仕様】工事写真帳は1シート構成、用紙1枚に3枚画像が入り、画像の右側には摘要欄があります。画像を読み込む位置をダブルクリックするとセルのサイズ(写真サイズに結合してあります)を取得して画像サイズを変更して格納します。
【問題点】2枚以上画像を読み込んだ状態で実行すると目的の画像のサイズが変更にならない場合があります。
画像を削除したことで画...続きを読む

Aベストアンサー

画像にわざわざ名前をつける必要はあるのでしょうか?
(以下は一部抜粋して、少しだけ手を入れました)

Dim pict As String
 ActiveSheet.Pictures.Insert(fname).Select
 pict = Selection.Name
 With ActiveSheet.Shapes(pict) '画像のサイズ変更
  .LockAspectRatio = False
  .Placement = xlFreeFloating
  .Placement = xlMove
  .Width = w
  .Height = h
 End With

これなら画像を繰り返し削除しても大丈夫に思います

QBitmap.GetPixelより高速なもの

いまVBでBitmap.GetPixelを使って、グレースケールの画像のRGBを取得しています。
まあグレースケールなんでRGB同じなのでとりあえずRの値を使うとして、
200*300の画像をFor文でBitmap.GetPixelを使うととてもじゃないぐらい遅いです。
ある程度調べると、LockBits()というものが見つかったのですが使い方がわかりません。 教えてください。

Aベストアンサー

補足されたコードをもう一度見直したほうがいいように思います

for LY ...
 for LX ...
  myBitmapの構築
  色情報の取得
  if 色判定 then
   Graphicsオブジェクトの生成
   描画
  end if
 next ' LX
next ' LY
といった構成になっています

2重ループの内側で myBitmapを毎回作成するのは無駄です
Graphicsオブジェクトの生成もループの内側でやった場合
連続して判定がTrueを返した場合毎回生成しなおします

変化しないものはループの外へ追い出して見ましょう

' Create a Bitmap object from an image file.
Dim myBitmap As New Bitmap(".\Test01.jpg")
Dim P As Graphics = PictureBox2.CreateGraphics

Dim LY As Long
' イメージ全体で行うなら 299をmyBitmap.Heightに
' 199を myBuitmp.Widthに変更したほうがいいでしょう
' 1行おきの処理なら Stepで調整する
For LY = 0 To 299 Step 2
  Dim LX As Long
  For LX = 0 To 199
    Try
      ' Get the color of a pixel within myBitmap.
      Dim pixelColor As Color = myBitmap.GetPixel(LX, LY)
      Red = pixelColor.R
      Label1.Text = "R" + Red
      If (Red > 40) Then
        P.FillRectangle(Brushes.White, LX, LY, 1, 1)
      End If
    Catch ex As Exception
    End Try
  Next
  ' 1行おきの処理をしたいのであれば For文にStepをつけましょう
  ' Forなど自動でカウントアップ(またはダウン)するものを
  ' コード内でいじってしまうのはあまり行儀がよくありません
  ' LY = LY + 1
Next

といった具合で 速度がずいぶん改善されるように思います

補足されたコードをもう一度見直したほうがいいように思います

for LY ...
 for LX ...
  myBitmapの構築
  色情報の取得
  if 色判定 then
   Graphicsオブジェクトの生成
   描画
  end if
 next ' LX
next ' LY
といった構成になっています

2重ループの内側で myBitmapを毎回作成するのは無駄です
Graphicsオブジェクトの生成もループの内側でやった場合
連続して判定がTrueを返した場合毎回生成しなおします

変化しないものはループの外へ追い出して見ましょう

' Cre...続きを読む

QVBAでJPGサイズ変更

VBAで
1.JPGファイルを読み込み
2.読み込んだJPGファイルの画像サイズ変更
3.再度JPG出力

の処理を行いたいのですが、どなたか分かる方がいますでしょうか?
サンプルコード、関連サイトなど教えていただけると幸いです。

お時間のある方、是非教えてください。

Aベストアンサー

某掲示板でshiraさんという方から教わったコードをアレンジさせていただきました。宣言部は別途投稿します。
Sub test()
Dim src As String,dst As String

src="c:\s.jpg"
dst="c:\d.jpg"
If Dir(dst) <> "" Then Kill (dst)
Call resizePicture(src,dst,20,7,70)
End Sub

Function resizePicture(ByVal srcPath As String,_
ByVal dstPath As String,_
Optional ByVal scalerate As Long=100,_
Optional ByVal InterpolationMode As InterpolationMode=InterpolationModeHighQualityBicubic,_
Optional ByVal jpegQuality As Long=85)
Dim IID_IDispatch As GUID
Dim pd As PICTDESC
Dim udtInputAs GdiplusStartupInput
Dim lngTokenAs Long,lngStatus As Long
Dim pGraphics As Long
Dim pSrcBmp As Long,pDstBmp As Long
Dim lngWidthAs Long,lngHeight As Long
Dim EncodParameters As EncoderParameters

udtInput.GdiplusVersion=1
If GdiplusStartup(lngToken,udtInput,ByVal 0&)<>0 Then
Exit Function
End If

If GdipCreateBitmapFromFile(ByVal StrPtr(srcPath),pSrcBmp)<>0 Then
GdiplusShutdown lngToken
Exit Function
End If

GdipGetImageWidth pSrcBmp,lngWidth
GdipGetImageHeight pSrcBmp,lngHeight
lngWidth=lngWidth * scalerate \ 100
lngHeight=lngHeight * scalerate \ 100

If GdipGetImageGraphicsContext(pSrcBmp,pGraphics)=0 Then
lngStatus=GdipCreateBitmapFromGraphics(lngWidth,lngHeight,pGraphics,pDstBmp)
GdipDeleteGraphics pGraphics
If lngStatus=0 Then
If GdipGetImageGraphicsContext(pDstBmp,pGraphics)=0 Then
GdipSetInterpolationMode pGraphics,InterpolationMode
GdipDrawImageRectI pGraphics,pSrcBmp,0,0,lngWidth,lngHeight
GdipDeleteGraphics pGraphics
EncodParameters.Count=1
With EncodParameters.Parameter(0)
.GUID=ConvCLSID(CLSID_Quality)
.NumberOfValues=1
.Type=4
.Value=VarPtr(jpegQuality)
End With
Call GdipSaveImageToFile(pDstBmp,StrPtr(dstPath),ConvCLSID(CLSID_JPEG),VarPtr(EncodParameters))
End If
GdipDisposeImage pDstBmp
End If
End If
GdipDisposeImage pSrcBmp
GdiplusShutdown lngToken
End Function

Private Function ConvCLSID(ByVal sGuid As String) As GUID
CLSIDFromString StrPtr(sGuid),ConvCLSID
End Function

某掲示板でshiraさんという方から教わったコードをアレンジさせていただきました。宣言部は別途投稿します。
Sub test()
Dim src As String,dst As String

src="c:\s.jpg"
dst="c:\d.jpg"
If Dir(dst) <> "" Then Kill (dst)
Call resizePicture(src,dst,20,7,70)
End Sub

Function resizePicture(ByVal srcPath As String,_
ByVal dstPath As String,_
Optional ByVal scalerate As Long=100,_
Optional ByVal InterpolationMode As InterpolationMode=InterpolationModeHighQualityBicubic,_
Op...続きを読む

QCで作成したDLL関数をVBから呼び 引数渡し方法

/**** Cプログラム *****/
int testAP( char* a)
aのポインタにアドレスを返します。

/**** VB プログラム****/
Public Declare Function testAP Lib "test.dll" (ByRef a As String) As Integer


Dim keydata As String * 128

lngRc = testAP(keydata)

上記VBのAPを実行するとアプリケーションエラーになります。
Cプログラムのデバックをすると入口ではaのポインタにはアドレスがセットされていて
、値を設定出来、最後まで正常動作して、VBとのインタフェースで落ちています。
VB6.exeでアプリケーションエラーになっています。

恐らく、VBにはポインタという概念が無いと聞いていてCのAPとの受け渡しに失敗して
そうなのですが、VBでの引き渡し方法が分かりません。
よろしくお願い致します。

Aベストアンサー

>__declspec(dllexport) int testAP(BSTR* cp_KeyData){
>
>→char*からBSTR*に変更しました。

だめです。そんな強引なことをしないでください。
char *でかまいません。
BSTR*にするとメモリ破壊が起きます。
__stdcallはどうしたんですか?
(ごめんなさい、アンダースコア2つですね)

>只、VCのデバックを行うと実行時エラー'49'
>DLLが正しく呼び出せません。が出力される。
>(DLL関数を呼んで処理が終了してVBに戻る所で出力されます。

VBのDeclareステートメントと、Cの処理があっていません。メモリを破壊しているのでしょう。
EXEにして動くのはたまたまでしょう。

QSQL Server時間切れについて

初めまして。SQL初心者です。
あるシステムにおいて、SQLサーバが無応答?になり、システムがダウンしてしまい、困っています。

Windows2000Server、SQL Server2000、VB6を用いてDBに定期的にRead&Write、及び各種のデータ表示を行っています。
ADOを使用して、接続や各コマンドを実行しているのですが、ごくたまに以下のエラーが出てしまいます。
Code:-2147217871,Description:時間切れになりました。Source:Microsoft OLE DB Provider for SQL Server,SQL State:HYT00,NativeError:0
過去ログや他サイトを調べた結果、コネクションのCommandTimeoutの秒数を延長させる、とあったので60秒に変更しました。
が、不定期(大体1週間~10日前後で夜中や朝方などにもあり)にこのエラーが出てしまい、約1時間~1時間半もダウンしています(この間のエラーをOn Errorではじいてログファイルに保存しています)。
毎分必ず実行しているストアド(20装置分のデータをUPDATEするので1分に20回実行する)があるのですが、必ずと言っていいほどこのストアド実行中に落ちています。
このストアドに5~6個のパラメータを渡し、複数のテーブルに対してUPDATE処理を行っています。
正常に動作している時は、数日間全く問題無いので、ストアドやVBのコードに間違いは無いと思います。

そこで、SQL Serverの設定等を見直したところ、1つ気になったところが。データベースファイル
\Microsoft SQL Server\MSSQL\Data\aaa.MDF
のサイズが14Gになっていました・・・。
このファイルにアクセスする時にSQL Serverで高負荷になってしまい、無応答のような状態になってしまうのでは?と思っていますがどうでしょう?

不定期に発生し、かつ再現性が無く、原因が掴めずに本当に困っています。
先輩方、何でも良いのでアドバイスをお願い致します。

初めまして。SQL初心者です。
あるシステムにおいて、SQLサーバが無応答?になり、システムがダウンしてしまい、困っています。

Windows2000Server、SQL Server2000、VB6を用いてDBに定期的にRead&Write、及び各種のデータ表示を行っています。
ADOを使用して、接続や各コマンドを実行しているのですが、ごくたまに以下のエラーが出てしまいます。
Code:-2147217871,Description:時間切れになりました。Source:Microsoft OLE DB Provider for SQL Server,SQL State:HYT00,NativeError:0
過去ログや他サイ...続きを読む

Aベストアンサー

14Gですか・・・大きいですね。
データの構造がどうなのか解らないので、
容量的に妥当かどうかはわかりませんが、
一度インデックスの再構築と圧縮を掛けてはどうでしょうか


CREATE PROCEDURE SP_COMPRESS AS

DECLARE @name varchar(30)

DECLARE tnames_cursor CURSOR FOR
SELECT name FROM sysobjects
WHERE type = 'U'
OPEN tnames_cursor

FETCH NEXT FROM tnames_cursor INTO @name
WHILE (@@fetch_status <> -1)
BEGIN
PRINT @name + 'のDBREINDEX...'
EXEC ('DBCC DBREINDEX ('+ @name + ')' )
FETCH NEXT FROM tnames_cursor INTO @name
END
DEALLOCATE tnames_cursor

dbcc SHRINKFILE("SampleDb_Log",1)
DBCC SHRINKDATABASE("SampleDb",1)
GO


データベース名は自分の環境に合わせてください。
また、バックアップは必ず取っておいてください。
14Gもあれば結構時間がかかると思いますが・・・

とりあえず参考程度に・・・

14Gですか・・・大きいですね。
データの構造がどうなのか解らないので、
容量的に妥当かどうかはわかりませんが、
一度インデックスの再構築と圧縮を掛けてはどうでしょうか


CREATE PROCEDURE SP_COMPRESS AS

DECLARE @name varchar(30)

DECLARE tnames_cursor CURSOR FOR
SELECT name FROM sysobjects
WHERE type = 'U'
OPEN tnames_cursor

FETCH NEXT FROM tnames_cursor INTO @name
WHILE (@@fetch_status <> -1)
BEGIN
PRINT @name + 'のDBREINDEX...'
EXEC ('DBCC DBREINDEX (...続きを読む


人気Q&Aランキング