sm1.bas

星子行主机控制系统用于主机管理,方便远程操作,通信等功能.更 方便用于局域网,管理速度快,连接简单方便.注意:星子行连接可用 于带路由主机与带路由主机之间连接,非路由与非路由之间连接.带

Attribute VB_Name = "Sm1"

Option Explicit


'全局变量___________________________-

Private houdc As Long      '设备场景的句柄
Private bm As BITMAP      '位图
Private hDIB As Long      '内存位图
Private hdc As Long       '内存设备场景
Private OldObj As Long    '选入设备场景的GDI对象
Private bi As BitMapInfo256   '位图信息
Private buffer() As Byte   '存放位图的组数

Public Sub m256x(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 + 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 = 8
        .biCompression = 0
        .biSizeImage = SizeOfArray
        End With
        I = 0
        For b = 0 To &HE0 Step &H20
            For g = 0 To &HE0 Step &H20
                For r = 0 To &HC0 Step &H40
                    bi.bmiColors(I) = IIf(b = &HE0, &HFF, b) * &H10000 + IIf(g = &HE0, &HFF, g) * &H100 + IIf(r = &HC0, &HFF, r)
                    I = I + 1
                Next r
            Next g
        Next b
    End With
   ReDim buffer(bi.bmiHeader.biSizeImage - 1) As Byte
    hdc = CreateCompatibleDC(0&)  '创建一个与特定设备场景一致的内存设备场景
    hDIB = CreateDIBSection256(hdc, bi, DIB_RGB_COLORS, I, 0&, 0&)
    
            '创建一个DIBSection。这是一个GDI对象，可象一幅与设备有关位图那样使用。但是，它在内部作为一幅与设备无关位图保存
    
    OldObj = SelectObject(hdc, hDIB) '每个设备场景都可能有选入其中的图形对象。其中包括位图、刷子、字体、画笔以及区域等等。
                                      '一次选入设备场景的只能有一个对象。选定的对象会在设备场景的绘图操作中使用。
                                      '例如，当前选定的画笔决定了在设备场景中描绘的线段颜色及样式
    
    
    '清理操作-----------------------
   
    DeleteObject bmp2
    
    '传送到被控端--------------------------------------------
    
    
     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"
    
     main1.Winsock2.SendData ok
     
     se = 256
     main1.Timer3.Enabled = True

End Sub

Public Sub m256z()

SelectObject hdc, OldObj
DeleteDC hdc
DeleteObject hDIB

End Sub





Public Sub M256y()
    
   
    Call BitBlt(hdc, 0&, 0&, bm.bmWidth, bm.bmHeight, houdc, 0&, 0&, vbSrcCopy)
    
    Call GetDIBits256(hdc, hDIB, 0, (bm.bmHeight), buffer(0), bi, 0) '将来自一幅位图的二进制位复制到一幅与设备无关的位图里
    
   
   
   
   Call one(buffer, bi.bmiHeader.biSizeImage - 1)
    
  
    
    
    ' Call form3.m256a(buffer(), bm.bmWidth, _
'bm.bmHeight, bm.bmWidthBytes, bm.bmPlanes, bm.bmBitsPixel, bm.bmBits)
  
    ' Call one(buffer(), bi.bmiHeader.biSizeImage - 1)
    
   
    '存盘用________________________________
   
 ' Open "c:\256.bmp" For Binary As #1
   
   
 ' Put #1, 1, bf
 ' Put #1, , bi
 ' Put #1, 1078, 0
 ' Put #1, , buffer
 ' Close #1
 
   
   End Sub
'main1.Winsock1.SendData 0
   
'main1.Winsock1.SendData buffer
'main1.Winsock1.SendData 0

  
   
    ' Call two(buffer, bi.bmiHeader.biSizeImage - 1)
   
   
  
  
  '传输用____________________________________________________--
  
  
  
 'Dim f1 As Long
 'Dim f2 As Long
 'Dim f3 As Long
 
 'Dim e1 As Long
 'Dim e2 As Long
 'e1 = 0
 'e2 = 0
 'Dim e3 As Long
 'e3 = 0
 
 'f1 = bi.bmiHeader.biSizeImage - 1
' MsgBox f1
 'f2 = 1024
 'f3 = f1 \ 1024
 ' Dim d1() As Byte
 ' ReDim d1(1023)
 'Dim xx As Long
'xx = 0
 
'Do While e1 < f3
 
' Do While e2 < f2
'

 
' d1(e2) = buffer(e2 + e1 * 1024)
' e2 = e2 + 1
' Loop
 ' main1.Caption = xx
'xx = xx + 1

'Put #2, , d1
' main1.Winsock1.SendData d1
' Sleep (1)
 'Exit Function
' e1 = e1 + 1
' e2 = 0
' Loop
 
' Dim h1 As Long
' h1 = f1 Mod 1024
 'MsgBox h1
' ReDim d1(h1)


' Do While e2 < h1
 'd1(e2) = buffer(e2 + e1 * 1024)
 'e2 = e2 + 1
 'Loop
 
' Put #2, , d1
 'MsgBox e2
'main1.Winsock1.SendData d1