🚀 go-pugleaf

In article <61as78$ji2$1@host06.interwave.or.jp>, bube@yyy.or.jp says...
>$B!!%^!<%8$H$O!"(BDOS$B%3%^%s%I$GI=$9$H$3$N$h$&$J;v$G$7$g$&$+!)(B
>
>$B!!(BCopy $B%U%!%$%kL>#1(B+$B%U%!%$%kL>#2(B...$B=q$-9~$_%U%!%$%kL>(B

$B0UL#$H$7$F$O!"$*$C$7$c$kDL$j$G$9!#(B

>$B!!$=$l$H!"$3$&$7$?>l9g!"FI$_9~$_$+$?$,J,$+$j$^$;$s!#(B

$B$3$N>l9g!"%U%!%$%k$N%5%$%:$r3P$($F$*$1$P!"J,3d$9$k$3$H$,$G$-$^$9$M(B?

[$B%U%!%$%k(B1$B$N%5%$%:(B] [$B%U%!%$%k(B2$B$N%5%$%:(B] [$B%U%!%$%k(B1$B$N%G!<%?(B]  [$B%U%!%$%k(B2$B$N%G!<%?(B]
$B$H$$$&%G!<%?$,=q$-9~$^$l$F$$$k%U%!%$%k$J$i$P!"=i$a$K%U%!%$%k(B1$B$H(B
$B%U%!%$%k(B2$B$N%5%$%:$rFI$_9~$_!"<!$K%U%!%$%k(B1$B$N%5%$%:$@$1%G!<%?$rFI$_9~$s$G(B
$B0l;~E*$J%U%!%$%k$K=q$-9~$_!"$=$7$F%U%!%$%k(B2$B$N%5%$%:$@$1%G!<%?$rFI$_9~$s$G(B
$BJL$N0l;~E*$J%U%!%$%k$K=q$-9~$a$PNI$$$o$1$G$9!#(B

$BBgNL$N%G!<%?$G$J$1$l$P!"$3$NJ}K!$G==J,$G$O$J$$$G$7$g$&$+!#(B
$B@596K!$G%S%C%H%^%C%W$NJ]B8$r9T$*$&$H$9$k$H!"7k9=<j4V$,$+$+$k$N$G!"(B
$B>e5-$NJ}K!$r$*$9$9$a$7$^$9!#(B

$B$J$*$3$N5-;v$N:G8e$K!"@596K!$G%S%C%H%^%C%W$NJ]B8$r9T$&%5%s%W%k$r(B
$B2C$($F$"$j$^$9(B($BCm(B:$BF0:nL$3NG'(B)$B!#7k9=BgJQ!"$H$$$&Nc$H$$$&$3$H$G(B...$B!#(B
$B$A$J$_$K!"(B"XXX.BMP"$B$H$$$&L>A0$GJ]B8$9$l$P!"B?J,%Z%$%s%H%V%i%7$G3+$1$^$9!#(B

>
>>  $B0l1~!"(BOLE $B%3%s%F%J%3%s%H%m!<%k$K%Z%$%s%H%V%i%7%*%V%8%'%/%H$J$I$r(B
>> $BE=$jIU$1$F;H$&J}K!$,$"$j$^$9!#$3$l$GJ]B8$O$G$-$k$N$G$9$,(B...$B!#(B
>
>$B!!$3$A$i$r:NMQ$7$h$&$H;W$C$?$N$G$9$,!"%S%C%H%^%C%W$r%/%j%C%W%\!<%I$K(B
>$BAw$C$?!!8e!"(BOLE$B%3%s%F%J%3%s%H%m!<%k$KE=$jIU$1$h$&$H;W$C$F$b!"(B"$BE=$jIU(B
>$B$1$i$l$^$;$s(B"$B$H%(%i!<$,=P$F;_$^$C$F$7$^$$$^$9!#(B

$B8fLH$J$5$$!#$3$l$O;d$N4*0c$$$G$7$?!#M>J,$J<j4V$r$+$1$5$;$F$7$^$C$F!"(B
$BBgJQ?=$7Lu$"$j$^$;$s!#?<$/$*OM$S?=$7>e$2$^$9!#(B


$BNc(B: $B%S%C%H%^%C%WJ]B8$N%5%s%W%k(B
Option Explicit
Option Base 0

#Const X86LONG = True

Public Const IDX_biSize = 0
Public Const IDX_biWidth = 1
Public Const IDX_biHeight = 2
Public Const IDX_biPackedData = 3
Public Const IDX_biCompression = 4
Public Const IDX_biSizeImage = 5
Public Const IDX_biXPelsPerMeter = 6
Public Const IDX_biYPeslPerMeter = 7
Public Const IDX_biClrUsed = 8
Public Const IDX_biClrImportant = 9

Public Const IDX_bmType = 0
Public Const IDX_bmWidth = 1
Public Const IDX_bmHeight = 2
Public Const IDX_bmWidthBytes = 3
Public Const IDX_bmPackedData = 4
Public Const IDX_bmBits = 5

Public Const UD_bmPlanes = 0
Public Const UD_bmBitsPixel = 1
Public Const UD_biPlanes = 2
Public Const UD_biBitCount = 3

Public Const SizeOfBITMAP = 24
Public Const SizeOfBITMAPINFOHEADER = 40
Public Const SizeOfRGBQUAD = 4
Public Const SizeOfBITMAPFILEHEADER = 14

Public Const BI_RGB As Long = 0
Public Const DIB_RGB_COLORS = 0
Public Const CBM_INIT As Long = 4

Public Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type

Declare Function GetBitmapObject Lib "gdi32" Alias "GetObjectA" _
    (ByVal hBitmap As Long, ByVal cbBuffer As Long, _
    ByRef LongArray As Long) As Long
Declare Function GetDIBits Lib "gdi32" (ByVal hDC As Long, _
    ByVal hBitmap As Long, ByVal uStartScan As Long, _
    ByVal cScanLine As Long, ByRef ByteArray As Byte, _
    LongArray As Long, ByVal uUsage As Long) As Long

Public Function UnpackData(Cmd As Integer, PackedData As Long) As Integer

#If X86LONG Then
    
    Select Case Cmd
        Case UD_bmPlanes, UD_biPlanes
            UnpackData = PackedData Mod &H10000
        Case UD_bmBitsPixel, UD_biBitCount
            UnpackData = Int(PackedData / &H10000)
    End Select

#End If

End Function


Public Function SaveDIBitmap(hDC As Long, hBitmap As Long, FileNO As Integer)

    Dim bm() As Long
    Dim bi() As Long
    Dim Bits() As Byte
    Dim cClrBits As Integer
    Dim biPlanes As Integer
    Dim biBitCount As Integer
    Dim bmPlanes As Integer
    Dim bmBitsPixel As Integer
    Dim bh As BITMAPFILEHEADER
    
    ReDim bm(SizeOfBITMAP / 4 - 1)

    GetBitmapObject hBitmap, SizeOfBITMAP, bm(0)
    
    bmPlanes = UnpackData(UD_bmPlanes, bm(IDX_bmPackedData))
    bmBitsPixel = UnpackData(UD_bmBitsPixel, bm(IDX_bmPackedData))
    
    cClrBits = bmPlanes * bmBitsPixel
    
    If cClrBits = 16 Or cClrBits = 32 Then
        ReDim bi(SizeOfBITMAPINFOHEADER / 4 + 3 - 1)
    ElseIf cClrBits = 24 Then
        ReDim bi(SizeOfBITMAPINFOHEADER / 4 - 1)
    Else
        ReDim bi(SizeOfBITMAPINFOHEADER / 4 + (SizeOfRGBQUAD / 4) * cClrBits - 1)
    End If
    
    bi(IDX_biSize) = SizeOfBITMAPINFOHEADER
    bi(IDX_biWidth) = bm(IDX_bmWidth)
    bi(IDX_biHeight) = bm(IDX_bmHeight)
    bi(IDX_biPackedData) = bm(IDX_bmPackedData)
    bi(IDX_biSizeImage) = Int((bi(IDX_biWidth) + 7) / 8) * bi(IDX_biHeight) * cClrBits
    bi(IDX_biClrImportant) = 0
    
    ReDim Bits(bi(IDX_biSizeImage))
    
    GetDIBits hDC, hBitmap, 0, bi(IDX_biHeight), Bits(0), bi(0), DIB_RGB_COLORS
    
    bh.bfType = &H4D42
    bh.bfSize = SizeOfBITMAPFILEHEADER
    bh.bfReserved1 = 0
    bh.bfReserved2 = 0
    
    bh.bfOffBits = SizeOfBITMAPFILEHEADER + bi(IDX_biSize)
    
    Put #FileNO, , bh
    Put #FileNO, , bi
    Put #FileNO, , Bits

End Function

-- 
$B:4F#@59((B <masahiro@cij.co.jp>