sam16.bas

来自「星子行V2.0(源码)公开星子行V3.0以上版本,都是由星子行V1.0和星子行V」· BAS 代码 · 共 103 行

Attribute VB_Name = "Sam16"

Option Explicit


Private houdc As Long        '设备场景的句柄
Private bm As BITMAP
Private bi As BitMapInfo16
Private hdc As Long, hDIB As Long, OldObj As Long
Private buffer() As Byte


Public Sub M16x(port1 As Long, port2 As Long)


Dim bmpwidth As Long   '设备场景的宽
Dim bmpheight As Long  '设备场景的高



houdc = GetDC(0&)

bmpwidth = GetDeviceCaps(houdc, HORZRES)  '根据指定设备场景代表的设备的功能返回信息
bmpheight = GetDeviceCaps(houdc, VERTRES)

Dim bmp2 As Long

bmp2 = CreateCompatibleBitmap(houdc, bmpwidth, bmpheight) '创建一幅与设备有关位图，它与指定的设备场景兼容

Dim SizeOfArray As Long, fp As Long
Dim bf As BITMAPFILEHEADER
Dim I As Long, r As Integer, g As Integer, b As Integer
    '
    Call GetObject(bmp2, Len(bm), bm)
    SizeOfArray = (((bm.bmWidth / 2 + 3) \ 4) * 4) * bm.bmHeight
    '
    With bf
        .bfType = "BM"
        .bfSize = Len(bf) + Len(bi) + SizeOfArray
        .bfReserved1 = 0
        .bfReserved2 = 0
        .bfOffBits = Len(bf) + Len(bi)
    End With
    With bi
        With .bmiHeader
        .biSize = Len(bi.bmiHeader)
        .biWidth = bm.bmWidth
        .biHeight = bm.bmHeight
        .biPlanes = 1
        .biBitCount = 4
        .biCompression = 0
        .biSizeImage = SizeOfArray
        End With
        For I = 0 To 15
            .bmiColors(I) = QBColor(I)
        Next I
    End With
    ReDim buffer(bi.bmiHeader.biSizeImage - 1) As Byte
    hdc = CreateCompatibleDC(0&)
    hDIB = CreateDIBSection16(hdc, bi, DIB_RGB_COLORS, I, 0&, 0&)
    OldObj = SelectObject(hdc, hDIB)
    'Call BitBlt(hDC, 0&, 0&, bm.bmWidth, bm.bmHeight, houdc, 0&, 0&, vbSrcCopy)
    'Call GetDIBits16(hDC, hDIB, 0, (bm.bmHeight), buffer(0), bi, 0)
    
    
    '清理操作----------------------------------
   
    DeleteObject bmp2
    
    
  ''   Call Form3.m16a(buffer(), bm.bmWidth, _
''bm.bmHeight, bm.bmWidthBytes, bm.bmPlanes, bm.bmBitsPixel, bm.bmBits)

  
    Dim su(6) As Long
     su(0) = bi.bmiHeader.biSizeImage - 1
     su(1) = bm.bmWidth
     su(2) = bm.bmHeight
     su(3) = port1
     su(4) = port2
     Dim ok As String
    
     ok = su(0) & "-" & su(1) & "-" & su(2) & "-" & su(3) & "-" & su(4) & "-" & "0" & "-" & "0" & "-" & "0"
    
     Main.Scmnet5.SendData ok
     se = 16
     Main.Timer3.Enabled = True
End Sub
Public Sub m16y()

 Call BitBlt(hdc, 0&, 0&, bm.bmWidth, bm.bmHeight, houdc, 0&, 0&, vbSrcCopy)
 Call GetDIBits16(hdc, hDIB, 0, (bm.bmHeight), buffer(0), bi, 0)
Call one(buffer(), bi.bmiHeader.biSizeImage - 1)

End Sub

Public Sub m16z()
    SelectObject hdc, OldObj
    DeleteDC hdc
    DeleteObject hDIB
   
End Sub