C# と VB.NET の質問掲示板

> あなたが書いたVBのソースを載せて、どこが悪いのか指摘を受けたほうが有意義だと思いますよ。

よもやまさんに紹介していただいたページをVBに変換しました。
http://www.adp-gmbh.ch/csharp/avi/write_avi.html

悪い点や誤り等ありましたらご指摘をお願いいたします。


以下ソースです。よろしくお願いします。
※ToUInt32についてはSystem.Convert.を省略して記載しています。

Imports System
Imports System.Runtime.InteropServices
Imports System.Drawing
Imports System.Drawing.Imaging

 _

Public Class AviWriter
	<StructLayout(LayoutKind.Sequential, Pack:=1)> _
	Private Structure AVISTREAMINFOW
		Public fccType, fccHandler, dwFlags, dwCaps As UInt32

		Public wPriority, wLanguage As UInt16

		Public dwScale, dwRate, dwStart, dwLength, dwInitialFrames, dwSuggestedBufferSize, dwQuality, dwSampleSize, rect_left, rect_top, rect_right, rect_bottom, dwEditCount, dwFormatChangeCount As UInt32

		Public szName0, szName1, ..... szName63 As UInt16
	End Structure 'AVISTREAMINFOW
	<StructLayout(LayoutKind.Sequential, Pack:=1)> _
		Private Structure AVICOMPRESSOPTIONS
		Public fccType As UInt32
		Public fccHandler As UInt32
		Public dwKeyFrameEvery As UInt32 ' only used with AVICOMRPESSF_KEYFRAMES
		Public dwQuality As UInt32
		Public dwBytesPerSecond As UInt32 ' only used with AVICOMPRESSF_DATARATE
		Public dwFlags As UInt32
		Public lpFormat As IntPtr
		Public cbFormat As UInt32
		Public lpParms As IntPtr
		Public cbParms As UInt32
		Public dwInterleaveEvery As UInt32
	End Structure 'AVICOMPRESSOPTIONS
	<StructLayout(LayoutKind.Sequential, Pack:=1)> _
	 Public Structure BITMAPINFOHEADER
		Public biSize As UInt32
		Public biWidth As Int32
		Public biHeight As Int32
		Public biPlanes As Int16
		Public biBitCount As Int16
		Public biCompression As UInt32
		Public biSizeImage As UInt32
		Public biXPelsPerMeter As Int32
		Public biYPelsPerMeter As Int32
		Public biClrUsed As UInt32
		Public biClrImportant As UInt32
	End Structure 'BITMAPINFOHEADER
	_

	Public Class AviException
		Inherits ApplicationException

		Public Sub New(ByVal s As String)
			MyBase.New(s)
		End Sub 'New

		Public Sub New(ByVal s As String, ByVal hr As Int32)
			MyBase.New(s)

			If hr = AVIERR_BADPARAM Then
				err_msg = "AVIERR_BADPARAM"
			Else
				err_msg = "unknown"
			End If
		End Sub 'New


		Public Function ErrMsg() As String
			Return err_msg
		End Function 'ErrMsg
		Private AVIERR_BADPARAM As Int32 = -2147205018
		Private err_msg As String
	End Class 'AviException

	Private Const OF_WRITE As Long = &H1
	Private Const OF_CREATE As Long = &H1000
	Private Const OF_SHARE_DENY_NONE As Long = &H40
	Private Const AVIIF_KEYFRAME As Long = &H10L

	Public Function Open(ByVal fileName As String, ByVal frameRate As UInt32, ByVal width As Integer, ByVal height As Integer) As Bitmap
		frameRate_ = frameRate
		width_ = width
		height_ = height
		bmp_ = New Bitmap(width, height, PixelFormat.Format24bppRgb)
		Dim bmpDat As BitmapData = bmp_.LockBits(New Rectangle(0, 0, width, height), ImageLockMode.ReadOnly, PixelFormat.Format24bppRgb)
		stride_ = bmpDat.Stride
		bmp_.UnlockBits(bmpDat)
		AVIFileInit()
		Dim hr As Integer = AVIFileOpen(pfile_, fileName, OF_CREATE Or OF_WRITE Or OF_SHARE_DENY_NONE, 0)

		If hr <> 0 Then
			Throw New AviException("error for AVIFileOpen")
		End If

		CreateStream()
		SetOptions()

		Return bmp_
	End Function 'Open


	Public Sub AddFrame()

		Dim bmpDat As BitmapData = bmp_.LockBits(New Rectangle(0, 0, CInt(width_), CInt(height_)), ImageLockMode.ReadOnly, PixelFormat.Format24bppRgb)

		Dim hr As Integer = AVIStreamWrite(psCompressed_, count_, 1, bmpDat.Scan0, CType(stride_ * height_, Int32), 0, 0, 0)
		' pointer to data
		' 16 = AVIIF_KEYFRAMe

		If hr <> 0 Then
			Throw New AviException("AVIStreamWrite")
		End If

		bmp_.UnlockBits(bmpDat)

		count_ += 1
	End Sub 'AddFrame


	Public Sub Close()
		AVIStreamRelease(ps_)
		AVIStreamRelease(psCompressed_)

		AVIFileRelease(pfile_)
		AVIFileExit()
	End Sub 'Close


	Private Sub CreateStream()
		Dim strhdr As New AVISTREAMINFOW
		strhdr.fccType = fccType_
		strhdr.fccHandler = fccHandler_
		strhdr.dwFlags = ToUInt32(0)
		strhdr.dwCaps = ToUInt32(0)
		strhdr.wPriority = ToUInt16(0)
		strhdr.wLanguage = ToUInt16(0)
		strhdr.dwScale = ToUInt32(1)
		strhdr.dwRate = frameRate_ ' Frames per Second
		strhdr.dwStart = ToUInt32(0)
		strhdr.dwLength = ToUInt32(0)
		strhdr.dwInitialFrames = ToUInt32(0)
		strhdr.dwSuggestedBufferSize = ToUInt32(height_ * stride_)
		strhdr.dwQuality = ToUInt32(4294967295)
		strhdr.dwSampleSize = ToUInt32(0)
		strhdr.rect_top = ToUInt32(0)
		strhdr.rect_left = ToUInt32(0)
		strhdr.rect_bottom = ToUInt32(height_)
		strhdr.rect_right = ToUInt32(width_)
		strhdr.dwEditCount = ToUInt32(0)
		strhdr.dwFormatChangeCount = ToUInt32(0)
		strhdr.szName0 = ToUInt16(0)
		strhdr.szName1 = ToUInt16(0)

		Dim hr As Integer = AVIFileCreateStream(pfile_, ps_, strhdr)

		If hr <> 0 Then
			Throw New AviException("AVIFileCreateStream")
		End If
	End Sub 'CreateStream


	Private Sub SetOptions()
		Dim opts As New AVICOMPRESSOPTIONS
		opts.fccType = ToUInt32(0) 'fccType_;
		opts.fccHandler = ToUInt32(0) 'fccHandler_;
		opts.dwKeyFrameEvery = ToUInt32(0)
		opts.dwQuality = ToUInt32(0) ' 0 .. 10000
		opts.dwFlags = ToUInt32(0) ' AVICOMRPESSF_KEYFRAMES = 4
		opts.dwBytesPerSecond = ToUInt32(0)
		opts.lpFormat = New IntPtr(0)
		opts.cbFormat = ToUInt32(0)
		opts.lpParms = New IntPtr(0)
		opts.cbParms = ToUInt32(0)
		opts.dwInterleaveEvery = ToUInt32(0)

		Dim p As AVICOMPRESSOPTIONS
		Dim pp As AVICOMPRESSOPTIONS

		Dim x As IntPtr = ps_
		Dim ptr_ps As IntPtr

		AVISaveOptions(0, ToUInt32(0), 1, ptr_ps, pp)

		' TODO: AVISaveOptionsFree(...)
		Dim hr As Integer = AVIMakeCompressedStream(psCompressed_, ps_, opts, 0)
		If hr <> 0 Then
			Throw New AviException("AVIMakeCompressedStream")
		End If

		Dim bi As New BITMAPINFOHEADER
		bi.biSize = ToUInt32(40)
		bi.biWidth = ToDecimal(width_)
		bi.biHeight = ToDecimal(height_)
		bi.biPlanes = 1
		bi.biBitCount = 24
		bi.biCompression = ToUInt32(0) ' 0 = BI_RGB
		bi.biSizeImage = ToUInt32(stride_ * height_)
		bi.biXPelsPerMeter = 0
		bi.biYPelsPerMeter = 0
		bi.biClrUsed = ToUInt32(0)
		bi.biClrImportant = ToUInt32(0)

		hr = AVIStreamSetFormat(psCompressed_, 0, bi, 40)
		If hr <> 0 Then
			Throw New AviException("AVIStreamSetFormat", hr)
		End If
	End Sub 'SetOptions

	Private Declare Sub AVIFileInit Lib "avifil32.dll" ()

	Private Declare Sub AVIFileExit Lib "avifil32.dll" ()

	Private Declare Function AVIFileOpen Lib "avifil32.dll" _
			 (ByRef ptr_pfile As Integer, ByVal fileName As String, _
			  ByVal flags As Integer, ByRef dummy As Integer) As Integer 'byval

	Private Declare Function AVIFileOpenW Lib "avifil32.dll" _
			 (ByRef ptr_pfile As Integer, ByVal fileName As String, _
			  ByVal flags As Integer, ByRef dummy As Integer) As Integer 'byval

	Private Declare Function AVIFileCreateStream Lib "avifil32.dll" _
			  (ByVal ptr_pfile As Integer, ByRef ptr_ptr_avi As IntPtr, _
			   ByRef ptr_streaminfo As AVISTREAMINFOW) As Long

	Private Declare Function AVIMakeCompressedStream Lib "avifil32.dll" _
			   (ByRef ppsCompressed As IntPtr, ByVal aviStream As IntPtr, _
				ByRef ao As AVICOMPRESSOPTIONS, ByVal dummy As Integer) As Integer

	Private Declare Function AVIStreamSetFormat Lib "avifil32.dll" _
			   (ByVal aviStream As IntPtr, ByVal lPos As Int32, _
				ByRef lpFormat As BITMAPINFOHEADER, ByVal cbFormat As Int32) As Integer

	Private Declare Function AVISaveOptions Lib "avifil32.dll" _
		  (ByVal hwnd As Integer, ByVal flags As UInt32, _
		   ByVal nStreams As Integer, _
		   ByRef ptr_ptr_avi As IntPtr, ByRef ao As AVICOMPRESSOPTIONS) As Integer 'byval

	Private Declare Function AVIStreamWrite Lib "avifil32.dll" _
		 (ByVal aviStream As IntPtr, ByVal lStart As Int32, _
		  ByVal lSamples As Int32, ByVal lpBuffer As IntPtr, _
		  ByVal cbBuffer As Int32, ByVal dwFlags As Int32, _
		  ByRef dummy1 As Int32, ByRef dummy2 As Int32) As Integer 'byval

	Private Declare Function AVIStreamRelease Lib "avifil32.dll" _
			   (ByVal aviStream As IntPtr) As Integer

	Private Declare Function AVIFileRelease Lib "avifil32.dll" _
			   (ByVal pfile As Integer) As Integer

	Private pfile_ As Integer = 0
	Private ps_ As New IntPtr(0)
	Private psCompressed_ As New IntPtr(0)
	Private frameRate_ As UInt32 = ToUInt32(0)
	Private count_ As Integer = 0
	Private width_ As Integer = 0
	Private stride_ As Integer = 0
	Private height_ As Integer = 0
	Private fccType_ As UInt32 = ToUInt32(1935960438) ' vids
	Private fccHandler_ As UInt32 = ToUInt32(808810089) ' IV50
	'1145656899;  // CVID
	Private bmp_ As Bitmap
End Class 'AviWriter

■No81148 (真田昌幸 さん) に返信
> >>Integer.MaxValueの箇所を100とかにすると正常に動作することから、Integer.MaxValueで
> >>オーバーフローが発生しているのは間違いないのですが、DrawLineの引数はInteger型なのに
> >>何故という疑問があります。
>>引数がInteger型だからといって、あらゆるメソッドがIntegerの全値域を受け入れなければならないってこともないでしょう。
>>例えばTCPのポート番号を引数に取るなら、型としてはIntegerを使うでしょうが有効なのは0〜65535だけです。
> 
> integerはVB2002以降は32bitかと
> 16bitなのはVB6までとVBA

VBA は関係無いですよね。

0〜65535 を表せる最小の型は System.UInt16 ですが、
そのための引数を System.Int32 にするのは珍しいことではありません。

たとえば日付型で、13月や32日を指定できないのは明確ですが、
DateTime の Month プロパティは、Byte ではなく Integer ですよね。


TCP のポート番号は、
　0〜1023　：ウェルノウンポート番号
　〜49151　：登録済みポート番号
　〜65535　：動的・プライベート ポート番号
であり、この範囲外を認めないというだけの話です。



   【符号なし整数型】
(a) 0〜255
(b) 0〜65535
(c) 0〜4294967295
(d) 0〜18446744073709551615


   【符号付き整数型】
(e)                -128〜127
(f)              -32768〜32767
(g)         -2147483648〜2147483647
(h)-9223372036854775808〜9223372036854775807

----------------------------
     .NET     VB.NET    VBA         VARIANT
(a)  Byte     Byte      Byte        VT_UI1 (17)
(b)  UInt16   UShort    非サポート  VT_UI2 (18)
(c)  UInt32   UInteger  非サポート  VT_UI4 (19)
(d)  UInt64   ULong     非サポート  VT_UI8 (21)
(e)  SByte    SByte     非サポート  VT_I1  (16)
(f)  Int16    Short     Integer     VT_I2  (2)
(g)  Int32    Integer   Long        VT_I4  (3)
(h)  Int64    Long      LongLong    VT_I8  (20)

ありがとうございます。

デフォルトではそのような機能はないのですね。

検索すると高速な変換コードが見つかりました。

http://www.wischik.com/lu/programmer/1bpp.html

これをVBに書き換えてみたのですが
エラーなくインデックス画像は出力されるのですが、
元画像と比べてかなり暗い色になってしまいます。

どこに変換ミスがあるか見ていただけないでしょうか？





    Private Function CopyToBpp(ByVal b As System.Drawing.Bitmap, ByVal bpp As Integer) As System.Drawing.Bitmap
        If ((bpp <> 1) _
                     AndAlso (bpp <> 8)) Then
            Throw New System.ArgumentException("1 or 8", "bpp")
        End If

        Dim h As Integer = b.Height
        Dim w As Integer = b.Width
        Dim hbm As IntPtr = b.GetHbitmap
        ' this is step (1)
        '
        ' Step (2): create the monochrome bitmap.
        ' "BITMAPINFO" is an interop-struct which we define below.
        ' In GDI terms, it's a BITMAPHEADERINFO followed by an array of two RGBQUADs
        Dim bmi As BITMAPINFO = New BITMAPINFO
        bmi.biSize = 40
        ' the size of the BITMAPHEADERINFO struct
        bmi.biWidth = w
        bmi.biHeight = h
        bmi.biPlanes = 1
        ' "planes" are confusing. We always use just 1. Read MSDN for more info.
        bmi.biBitCount = CType(bpp, Short)
        ' ie. 1bpp or 8bpp
        bmi.biCompression = BI_RGB
        ' ie. the pixels in our RGBQUAD table are stored as RGBs, not palette indexes
        bmi.biSizeImage = CType((((w + 7) And 4294967288) * (h / 8)), UInteger)
        bmi.biXPelsPerMeter = 1000000
        ' not really important
        bmi.biYPelsPerMeter = 1000000
        ' not really important
        ' Now for the colour table.
        Dim ncols As UInteger = CUInt(1 + bpp)
        ' 2 colours for 1bpp; 256 colours for 8bpp
        bmi.biClrUsed = ncols
        bmi.biClrImportant = ncols
        bmi.cols = New UInteger((256) - 1) {}
        ' The structure always has fixed size 256, even if we end up using fewer colours
        If (bpp = 1) Then
            bmi.cols(0) = MAKERGB(0, 0, 0)
            bmi.cols(1) = MAKERGB(255, 255, 255)
        Else
            Dim i As Integer = 0
            Do While (i < ncols)
                bmi.cols(i) = MAKERGB(i, i, i)
                i = (i + 1)
            Loop

        End If

        ' For 8bpp we've created an palette with just greyscale colours.
        ' You can set up any palette you want here. Here are some possibilities:
        ' greyscale: for (int i=0; i<256; i++) bmi.cols[i]=MAKERGB(i,i,i);
        ' rainbow: bmi.biClrUsed=216; bmi.biClrImportant=216; int[] colv=new int[6]{0,51,102,153,204,255};
        '          for (int i=0; i<216; i++) bmi.cols[i]=MAKERGB(colv[i/36],colv[(i/6)%6],colv[i%6]);
        ' optimal: a difficult topic: http://en.wikipedia.org/wiki/Color_quantization
        ' 
        ' Now create the indexed bitmap "hbm0"
        Dim bits0 As IntPtr
        ' not used for our purposes. It returns a pointer to the raw bits that make up the bitmap.
        Dim hbm0 As IntPtr = CreateDIBSection(IntPtr.Zero, bmi, DIB_RGB_COLORS, bits0, IntPtr.Zero, 0)
        '
        ' Step (3): use GDI's BitBlt function to copy from original hbitmap into monocrhome bitmap
        ' GDI programming is kind of confusing... nb. The GDI equivalent of "Graphics" is called a "DC".
        Dim sdc As IntPtr = GetDC(IntPtr.Zero)
        ' First we obtain the DC for the screen
        ' Next, create a DC for the original hbitmap
        Dim hdc As IntPtr = CreateCompatibleDC(sdc)
        SelectObject(hdc, hbm)
        ' and create a DC for the monochrome hbitmap
        Dim hdc0 As IntPtr = CreateCompatibleDC(sdc)
        SelectObject(hdc0, hbm0)
        ' Now we can do the BitBlt:
        BitBlt(hdc0, 0, 0, w, h, hdc, 0, 0, SRCCOPY)
        ' Step (4): convert this monochrome hbitmap back into a Bitmap:
        Dim b0 As System.Drawing.Bitmap = System.Drawing.Bitmap.FromHbitmap(hbm0)
        '
        ' Finally some cleanup.
        DeleteDC(hdc)
        DeleteDC(hdc0)
        ReleaseDC(IntPtr.Zero, sdc)
        DeleteObject(hbm)
        DeleteObject(hbm0)
        '
        Return b0
    End Function

    <System.Runtime.InteropServices.StructLayout(System.Runtime.InteropServices.LayoutKind.Sequential)>
    Public Structure BITMAPINFO

        Public biSize As UInteger
        Public biWidth As Integer
        Public biHeight As Integer
        Public biPlanes As Short
        Public biBitCount As Short
        Public biCompression As UInteger
        Public biSizeImage As UInteger
        Public biXPelsPerMeter As Integer
        Public biYPelsPerMeter As Integer
        Public biClrUsed As UInteger
        Public biClrImportant As UInteger

        <System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValArray, SizeConst:=256)>
        Public cols() As UInteger
    End Structure


    Public Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As IntPtr) As Boolean

    Public Declare Function GetDC Lib "user32.dll" (ByVal hwnd As IntPtr) As IntPtr

    Public Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As IntPtr) As IntPtr

    Public Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As IntPtr, ByVal hdc As IntPtr) As Integer

    Public Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As IntPtr) As Integer

    Public Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As IntPtr, ByVal hgdiobj As IntPtr) As IntPtr

    Public Declare Function BitBlt Lib "gdi32.dll" (ByVal hdcDst As IntPtr, ByVal xDst As Integer, ByVal yDst As Integer, ByVal w As Integer, ByVal h As Integer, ByVal hdcSrc As IntPtr, ByVal xSrc As Integer, ByVal ySrc As Integer, ByVal rop As Integer) As Integer

    Private SRCCOPY As Integer = 13369376

    Private Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal hdc As IntPtr, ByRef bmi As BITMAPINFO, ByVal Usage As UInteger, ByRef bits As IntPtr, ByVal hSection As IntPtr, ByVal dwOffset As UInteger) As IntPtr

    Private BI_RGB As UInteger = 0

    Private DIB_RGB_COLORS As UInteger = 0

    Private Function MAKERGB(ByVal r As Integer, ByVal g As Integer, ByVal b As Integer) As UInteger
        Return (CType((b And 255), UInteger) _
                     Or (CType(((r And 255) _
                     + 8), UInteger) Or CType(((g And 255) _
                     + 16), UInteger)))
    End Function