module1.bas

vb编写机器人遥控程序

Attribute VB_Name = "Module1"
Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    
  Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    
  Public Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
    
  Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    
  Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
    
  Public Const RGN_OR = 2
   Public Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
  Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
 Public Const HWND_TOPMOST& = -1
Public Const SWP_NOSIZE& = &H1
    
  Public Type BITMAP       '14   bytes
  bmType   As Long
  bmWidth   As Long
  bmHeight   As Long
  bmWidthBytes   As Long
  bmPlanes   As Integer
  bmBitsPixel   As Integer
  bmBits   As Long
  End Type
    
  Dim bmByte()     As Byte
    
  Public Declare Function ReleaseCapture Lib "user32" () As Long
    
  Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    
  'Public   Const   WM_SYSCOMMAND   =   &H112
  'Public   Const   SC_MOVE   =   &HF012
  Public Const HTCAPTION = 2
  Public Const WM_NCLBUTTONDOWN = &HA1
    
    
    
    
    
    
    
    
    
    
  Public Sub SetAutoRgn(hForm As Form, Optional transColor As Byte = vbNull)
  Dim X     As Long, Y       As Long
  Dim Rgn1     As Long, Rgn2       As Long
  Dim SPos     As Long, EPos       As Long
  Dim bm     As BITMAP
  Dim hbm     As Long
  Dim Wid     As Long, Hgt       As Long
  Dim xoff     As Long, yoff       As Long
    
  '获取窗体背景图片尺寸
    
  hbm = hForm.Picture
  GetObjectAPI hbm, Len(bm), bm
  Wid = bm.bmWidth
  Hgt = bm.bmHeight
    
    
  ReDim bmByte(1 To Wid, 1 To Hgt)
  GetBitmapBits hbm, Wid * Hgt, bmByte(1, 1)               '获取图像数组
    
    
  '如果没有传入transColor参数，则用第一个像素作为透明色
    
  If transColor = vbNull Then transColor = bmByte(1, 1)
    
  Rgn1 = CreateRectRgn(0, 0, 0, 0)
    
  For Y = 1 To Hgt             '逐行扫描
  X = 0
  Do
  X = X + 1
    
  While (bmByte(X, Y) = transColor) And (X < Wid)
  X = X + 1           '跳过是透明色的点
  Wend
  SPos = X
  While (bmByte(X, Y) <> transColor) And (X < Wid)
  X = X + 1           '跳过不是透明色的点
  Wend
  EPos = X - 1
    
  '这一段是合并区域
  If SPos <= EPos Then
  Rgn2 = CreateRectRgn(SPos - 1, Y - 1, EPos, Y)
  CombineRgn Rgn1, Rgn1, Rgn2, RGN_OR
  DeleteObject Rgn2
  End If
  Loop Until X >= Wid
  Next Y
    
  SetWindowRgn hForm.hWnd, Rgn1, True         '设定窗体形状区域
  DeleteObject Rgn1
    
  End Sub