本人用VB编写赌场轮盘游戏遇到的难题，请高手指点！ - 编程论坛

#2

lowxiong2013-03-02 17:03

用api函数PlgBlt，那转起来真叫一个顺畅啊！

#3

shi7812032013-03-03 12:27

以下是引用lowxiong在2013-3-2 17:03:46的发言：

用api函数PlgBlt，那转起来真叫一个顺畅啊！

Declare Function PlgBlt Lib "gdi32" (ByVal hdcDest As Long, lpPoint As POINTAPI, ByVal hdcSrc As Long, ByVal nXSrc As Long, ByVal nYSrc As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hbmMask As Long, ByVal xMask As Long, ByVal yMask As Long) As Long
网上找不到关于这个函数的例子，你能举一个例子说明一下可以吗？

#4

lowxiong2013-03-03 15:37

新建一工程，添加两个picturebox控件，一个timer控件，一个commandbutton控件，拷贝下列代码，运行就看的到效果（把旋转角度设为-5，你会发现转着转着字就变形了，这是因为小数和整数的误差造成的，怎么克服，你自己想办法，可以解决的。）

程序代码：

Private Type PointApi
  x As Long
  y As Long
End Type

Private Declare Function PlgBlt Lib "gdi32" (ByVal hdcDest As Long, lpPoint As PointApi, _
   ByVal hdcSrc As Long, ByVal nXSrc As Long, ByVal nYSrc As Long, ByVal nWidth As Long, _
   ByVal nHeight As Long, ByVal hbmMask As Long, ByVal xMask As Long, ByVal yMask As Long) As Long

Dim TZb(2) As PointApi    '目标图形当前坐标，数组中3个元素存储顺序为左上角、右上角、左下角
Dim rS As Single          '旋转半径

Private Sub Command1_Click()
  Dim xo As Single, yo As Single, xs As Single, ys As Single
  If Command1.Caption = "转" Then
    Command1.Caption = "停"
    xo = Picture2.Width * 0.5: yo = Picture2.Height * 0.5     '目标区域圆心
    xs = Picture1.Width * 0.5: ys = Picture1.Height * 0.5     '源图像圆心
    TZb(0).x = xo - xs: TZb(0).y = yo - ys
    TZb(1).x = xo + xs: TZb(1).y = yo - ys
    TZb(2).x = xo - xs: TZb(2).y = yo + ys
    rS = Sqr((xo - TZb(0).x) ^ 2 + (yo - TZb(0).y) ^ 2) '求取半径
    Picture2.Cls
    PlgBlt Picture2.hDC, TZb(0), Picture1.hDC, 0, 0, Picture1.Width, Picture1.Height, 0, 0, 0
    Picture2.Refresh
    Timer1.Interval = 10
  Else
    Timer1.Interval = 0
    Command1.Caption = "转"
    Picture2.Cls
  End If

End Sub

Private Sub Form_Load()
  Me.Height = 5730: Me.Width = 10755: Me.ScaleMode = 3
  Picture1.Height = 25: Picture1.Width = 145: Picture1.ScaleMode = 3: Picture1.Left = 32: Picture1.Top = 24
  Picture1.FontName = "宋体": Picture1.FontSize = 18: Picture1.BorderStyle = 0: Picture1.Appearance = 0: Picture1.AutoRedraw = True
  Command1.Caption = "转": Command1.Height = 49: Command1.Width = 121: Command1.Top = 216: Command1.Left = 40
  Picture2.Left = 224: Picture2.Top = 0: Picture2.ScaleMode = 3: Picture2.Width = 473: Picture2.Height = 337
  Picture2.BorderStyle = 0: Picture2.Appearance = 0: Picture2.AutoRedraw = True
  Picture1.Print "转死人不偿命"
End Sub

Private Sub Timer1_Timer()
  Dim xo As Single, yo As Single, angle As Integer
  If Command1.Caption = "转" Then Exit Sub
  '根据当前坐标、半径计算转动一个角度后的各点坐标
  xo = Picture2.Width * 0.5: yo = Picture2.Height * 0.5     '目标区域圆心
  angle = -20                                                '设定转动角度，负数顺时针转，正数逆时针转
  '如果设计轮盘转动可以设计一个加速转动后减速停止的过程，可把angle作为sin函数变量，当angle为0时就停了
  TZb(0) = getNewZb(angle, TZb(0), xo, yo, rS)              '左上角坐标
  TZb(1) = getNewZb(angle, TZb(1), xo, yo, rS)              '右上角坐标
  TZb(2) = getNewZb(angle, TZb(2), xo, yo, rS)              '左下角坐标
  Picture2.Cls
  PlgBlt Picture2.hDC, TZb(0), Picture1.hDC, 0, 0, Picture1.Width, Picture1.Height, 0, 0, 0
  Picture2.Refresh
End Sub

Private Function getNewZb(jiao As Integer, oldZb As PointApi, xo As Single, yo As Single, rHalf As Single) As PointApi
  '根据圆点坐标、圆上一点坐标、圆半径求转过一个角度jiao后的坐标
  Dim x As Single, y As Single, h As Single
  h = jiao * 3.1415926 / 180 '把角度换算为弧度
  x = (oldZb.x - xo) * Cos(h) + (oldZb.y - yo) * Sin(h) + xo
  y = (oldZb.y - yo) * Cos(h) + yo - (oldZb.x - xo) * Sin(h)
  '记住上述两个算法，复习复习下三角函数就知道为什么这样算了。
  getNewZb.x = x
  getNewZb.y = y
End Function

#5

曙光电子2013-03-04 17:08

另一种旋转方法
代码:
Option Explicit

Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long

Private fnt As CLogFont

Private Sub Check1_Click()
   Timer1.Enabled = CBool(Check1.Value)
   HScroll1.Enabled = Not Timer1.Enabled
   If Timer1.Enabled Then
      HScroll1.Value = 0
      Picture1.Cls
   End If
End Sub

Private Sub Command1_Click()
   Picture1.Cls
End Sub

Private Sub Command2_Click()
End
End Sub

Private Sub Form_Load()
   Set fnt = New CLogFont
   Set fnt.LogFont = Picture1.Font
   HScroll1.Value = 0
   Set Me.Icon = Nothing
End Sub

Private Sub Form_Resize()
   On Error Resume Next
   With HScroll1
      .Width = Me.ScaleWidth - .Left * 2
      Picture1.Move .Left, Picture1.Top, Me.ScaleWidth - .Left * 2, Me.ScaleHeight - Picture1.Top - .Left
      Command1.Left = Me.ScaleWidth - .Left - Command1.Width
      Check1.Left = Me.ScaleWidth - .Left - Check1.Width
   End With
End Sub

Private Sub HScroll1_Change()
   fnt.Rotation = HScroll1.Value
   Label1.Caption = "&旋转角度 (" & HScroll1.Value & "):"
End Sub

Private Sub HScroll1_Scroll()
   Label1.Caption = "&旋转角度 (" & HScroll1.Value & "):"
End Sub

Private Sub Label2_Click()

End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
   Dim hFont As Long
   With Picture1
      hFont = SelectObject(.hDC, fnt.Handle)
      .CurrentX = X
      .CurrentY = Y
      Picture1.Print "胡大勤: " & fnt.Rotation
      Call SelectObject(.hDC, hFont)
   End With
End Sub

Private Sub Timer1_Timer()
   With HScroll1
      If .Value = .Max Then
         .Value = .Min
      Else
         .Value = .Value + .LargeChange
      End If
      If (.Value Mod 360) = 0 Then Picture1.Cls
   End With
   With Picture1
      Picture1_MouseUp 0, 0, .ScaleWidth \ 2, .ScaleHeight \ 2
   End With
End Sub

类模块代码:
Option Explicit

Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64

Private Const CLIP_DEFAULT_PRECIS = 0
Private Const CLIP_CHARACTER_PRECIS = 1
Private Const CLIP_STROKE_PRECIS = 2
Private Const CLIP_MASK = &HF
Private Const CLIP_LH_ANGLES = 16
Private Const CLIP_TT_ALWAYS = 32
Private Const CLIP_EMBEDDED = 128

Private Const DEFAULT_QUALITY = 0
Private Const DRAFT_QUALITY = 1
Private Const PROOF_QUALITY = 2

Private Const DEFAULT_PITCH = 0
Private Const FIXED_PITCH = 1
Private Const VARIABLE_PITCH = 2

Private Const ANSI_CHARSET = 0
Private Const DEFAULT_CHARSET = 1
Private Const SYMBOL_CHARSET = 2
Private Const SHIFTJIS_CHARSET = 128
Private Const HANGEUL_CHARSET = 129
Private Const CHINESEBIG5_CHARSET = 136
Private Const OEM_CHARSET = 255

Private Const FF_DONTCARE = 0
Private Const FF_ROMAN = 16

Private Const FF_SWISS = 32

Private Const FF_MODERN = 48

Private Const FF_SCRIPT = 64
Private Const FF_DECORATIVE = 80

Private Const FW_DONTCARE = 0
Private Const FW_THIN = 100
Private Const FW_EXTRALIGHT = 200
Private Const FW_LIGHT = 300
Private Const FW_NORMAL = 400
Private Const FW_MEDIUM = 500
Private Const FW_SEMIBOLD = 600
Private Const FW_BOLD = 700
Private Const FW_EXTRABOLD = 800
Private Const FW_HEAVY = 900

Private Const FW_ULTRALIGHT = FW_EXTRALIGHT
Private Const FW_REGULAR = FW_NORMAL
Private Const FW_DEMIBOLD = FW_SEMIBOLD
Private Const FW_ULTRABOLD = FW_EXTRABOLD
Private Const FW_BLACK = FW_HEAVY

Private Const OUT_DEFAULT_PRECIS = 0
Private Const OUT_STRING_PRECIS = 1
Private Const OUT_CHARACTER_PRECIS = 2
Private Const OUT_STROKE_PRECIS = 3
Private Const OUT_TT_PRECIS = 4
Private Const OUT_DEVICE_PRECIS = 5
Private Const OUT_RASTER_PRECIS = 6
Private Const OUT_TT_ONLY_PRECIS = 7
Private Const OUT_OUTLINE_PRECIS = 8

Private Type LogFont
   lfHeight As Long
   lfWidth As Long
   lfEscapement As Long
   lfOrientation As Long
   lfWeight As Long
   lfItalic As Byte
   lfUnderline As Byte
   lfStrikeOut As Byte
   lfCharSet As Byte
   lfOutPrecision As Byte
   lfClipPrecision As Byte
   lfQuality As Byte
   lfPitchAndFamily As Byte
   lfFaceName As String * LF_FACESIZE
End Type

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LogFont) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Const LOGPIXELSY = 90

Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long

Private m_Font As StdFont
Private m_hFont As Long
Private m_Rotation As Single

Private Sub Class_Terminate()

   If m_hFont Then
      Call DeleteObject(m_hFont)
      Set m_Font = Nothing
   End If
End Sub

Public Property Set LogFont(ByVal NewFont As Font)
   If m_hFont Then
      Call DeleteObject(m_hFont)
      m_hFont = 0
   End If

   If NewFont Is Nothing Then
      Set m_Font = Nothing
   Else

      Set m_Font = New StdFont
      With m_Font
         .Bold = NewFont.Bold
         .Charset = NewFont.Charset
         .Italic = NewFont.Italic
         .Name = NewFont.Name
         .Size = NewFont.Size
         .Strikethrough = NewFont.Strikethrough
         .Underline = NewFont.Underline
         .Weight = NewFont.Weight
      End With
      m_hFont = CreateLogFont
   End If
End Property

Public Property Get LogFont() As Font
   Set LogFont = m_Font
End Property

Public Property Let Rotation(ByVal NewVal As Single)
   If NewVal <> m_Rotation Then
      m_Rotation = NewVal
      If m_hFont Then
         Call DeleteObject(m_hFont)
         m_hFont = 0
      End If
      If Not (m_Font Is Nothing) Then
         m_hFont = CreateLogFont
      End If
   End If
End Property

Public Property Get Rotation() As Single
   Rotation = m_Rotation
End Property

Public Property Get Handle() As Long
   Handle = m_hFont
End Property

Private Function CreateLogFont() As Long
   Dim lf As LogFont
   Dim hWnd As Long
   Dim hDC As Long

   hWnd = GetDesktopWindow
   hDC = GetDC(hWnd)

   With lf

      .lfHeight = -(m_Font.Size * GetDeviceCaps(hDC, LOGPIXELSY)) / 72
      .lfWidth = 0
      .lfEscapement = m_Rotation * 10
      .lfOrientation = .lfEscapement
      .lfWeight = m_Font.Weight
      .lfItalic = m_Font.Italic
      .lfUnderline = m_Font.Underline
      .lfStrikeOut = m_Font.Strikethrough
      .lfClipPrecision = CLIP_DEFAULT_PRECIS
      .lfQuality = PROOF_QUALITY
      .lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
      .lfFaceName = m_Font.Name & vbNullChar

      .lfCharSet = m_Font.Charset
      If .lfCharSet = OEM_CHARSET Then
         If (m_Rotation Mod 360) <> 0 Then
            .lfCharSet = ANSI_CHARSET
         End If
      End If

      If (m_Rotation Mod 360) <> 0 Then
         .lfOutPrecision = OUT_TT_ONLY_PRECIS
      Else
         .lfOutPrecision = OUT_DEFAULT_PRECIS
      End If
   End With

   CreateLogFont = CreateFontIndirect(lf)
   Call ReleaseDC(hWnd, hDC)
End Function

只有本站会员才能查看附件，请登录

#6

shi7812032013-03-04 22:37

以下是引用曙光电子在2013-3-4 17:08:25的发言：

另一种旋转方法
代码:
Option Explicit

Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long

Private fnt As CLogFont

Private Sub Check1_Click()
   Timer1.Enabled = CBool(Check1.Value)
   HScroll1.Enabled = Not Timer1.Enabled
   If Timer1.Enabled Then
      HScroll1.Value = 0
      Picture1.Cls
   End If
End Sub

Private Sub Command1_Click()
   Picture1.Cls
End Sub

Private Sub Command2_Click()
End
End Sub

Private Sub Form_Load()
   Set fnt = New CLogFont
   Set fnt.LogFont = Picture1.Font
   HScroll1.Value = 0
   Set Me.Icon = Nothing
End Sub

Private Sub Form_Resize()
   On Error Resume Next
   With HScroll1
      .Width = Me.ScaleWidth - .Left * 2
      Picture1.Move .Left, Picture1.Top, Me.ScaleWidth - .Left * 2, Me.ScaleHeight - Picture1.Top - .Left
      Command1.Left = Me.ScaleWidth - .Left - Command1.Width
      Check1.Left = Me.ScaleWidth - .Left - Check1.Width
   End With
End Sub

Private Sub HScroll1_Change()
   fnt.Rotation = HScroll1.Value
   Label1.Caption = "&旋转角度 (" & HScroll1.Value & "):"
End Sub

Private Sub HScroll1_Scroll()
   Label1.Caption = "&旋转角度 (" & HScroll1.Value & "):"
End Sub

Private Sub Label2_Click()

End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
   Dim hFont As Long
   With Picture1
      hFont = SelectObject(.hDC, fnt.Handle)
      .CurrentX = X
      .CurrentY = Y
      Picture1.Print "胡大勤: " & fnt.Rotation
      Call SelectObject(.hDC, hFont)
   End With
End Sub

Private Sub Timer1_Timer()
   With HScroll1
      If .Value = .Max Then
         .Value = .Min
      Else
         .Value = .Value + .LargeChange
      End If
      If (.Value Mod 360) = 0 Then Picture1.Cls
   End With
   With Picture1
      Picture1_MouseUp 0, 0, .ScaleWidth \ 2, .ScaleHeight \ 2
   End With
End Sub

类模块代码:
Option Explicit

Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64

Private Const CLIP_DEFAULT_PRECIS = 0
Private Const CLIP_CHARACTER_PRECIS = 1
Private Const CLIP_STROKE_PRECIS = 2
Private Const CLIP_MASK = &HF
Private Const CLIP_LH_ANGLES = 16
Private Const CLIP_TT_ALWAYS = 32
Private Const CLIP_EMBEDDED = 128

Private Const DEFAULT_QUALITY = 0
Private Const DRAFT_QUALITY = 1
Private Const PROOF_QUALITY = 2

Private Const DEFAULT_PITCH = 0
Private Const FIXED_PITCH = 1
Private Const VARIABLE_PITCH = 2

Private Const ANSI_CHARSET = 0
Private Const DEFAULT_CHARSET = 1
Private Const SYMBOL_CHARSET = 2
Private Const SHIFTJIS_CHARSET = 128
Private Const HANGEUL_CHARSET = 129
Private Const CHINESEBIG5_CHARSET = 136
Private Const OEM_CHARSET = 255

Private Const FF_DONTCARE = 0
Private Const FF_ROMAN = 16

Private Const FF_SWISS = 32

Private Const FF_MODERN = 48

Private Const FF_SCRIPT = 64
Private Const FF_DECORATIVE = 80

Private Const FW_DONTCARE = 0
Private Const FW_THIN = 100
Private Const FW_EXTRALIGHT = 200
Private Const FW_LIGHT = 300
Private Const FW_NORMAL = 400
Private Const FW_MEDIUM = 500
Private Const FW_SEMIBOLD = 600
Private Const FW_BOLD = 700
Private Const FW_EXTRABOLD = 800
Private Const FW_HEAVY = 900

Private Const FW_ULTRALIGHT = FW_EXTRALIGHT
Private Const FW_REGULAR = FW_NORMAL
Private Const FW_DEMIBOLD = FW_SEMIBOLD
Private Const FW_ULTRABOLD = FW_EXTRABOLD
Private Const FW_BLACK = FW_HEAVY

Private Const OUT_DEFAULT_PRECIS = 0
Private Const OUT_STRING_PRECIS = 1
Private Const OUT_CHARACTER_PRECIS = 2
Private Const OUT_STROKE_PRECIS = 3
Private Const OUT_TT_PRECIS = 4
Private Const OUT_DEVICE_PRECIS = 5
Private Const OUT_RASTER_PRECIS = 6
Private Const OUT_TT_ONLY_PRECIS = 7
Private Const OUT_OUTLINE_PRECIS = 8

Private Type LogFont
   lfHeight As Long
   lfWidth As Long
   lfEscapement As Long
   lfOrientation As Long
   lfWeight As Long
   lfItalic As Byte
   lfUnderline As Byte
   lfStrikeOut As Byte
   lfCharSet As Byte
   lfOutPrecision As Byte
   lfClipPrecision As Byte
   lfQuality As Byte
   lfPitchAndFamily As Byte
   lfFaceName As String * LF_FACESIZE
End Type

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LogFont) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Const LOGPIXELSY = 90

Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long

Private m_Font As StdFont
Private m_hFont As Long
Private m_Rotation As Single

Private Sub Class_Terminate()

   If m_hFont Then
      Call DeleteObject(m_hFont)
      Set m_Font = Nothing
   End If
End Sub

Public Property Set LogFont(ByVal NewFont As Font)
   If m_hFont Then
      Call DeleteObject(m_hFont)
      m_hFont = 0
   End If

   If NewFont Is Nothing Then
      Set m_Font = Nothing
   Else

      Set m_Font = New StdFont
      With m_Font
         .Bold = NewFont.Bold
         .Charset = NewFont.Charset
         .Italic = NewFont.Italic
         .Name = NewFont.Name
         .Size = NewFont.Size
         .Strikethrough = NewFont.Strikethrough
         .Underline = NewFont.Underline
         .Weight = NewFont.Weight
      End With
      m_hFont = CreateLogFont
   End If
End Property

Public Property Get LogFont() As Font
   Set LogFont = m_Font
End Property

Public Property Let Rotation(ByVal NewVal As Single)
   If NewVal <> m_Rotation Then
      m_Rotation = NewVal
      If m_hFont Then
         Call DeleteObject(m_hFont)
         m_hFont = 0
      End If
      If Not (m_Font Is Nothing) Then
         m_hFont = CreateLogFont
      End If
   End If
End Property

Public Property Get Rotation() As Single
   Rotation = m_Rotation
End Property

Public Property Get Handle() As Long
   Handle = m_hFont
End Property

Private Function CreateLogFont() As Long
   Dim lf As LogFont
   Dim hWnd As Long
   Dim hDC As Long

   hWnd = GetDesktopWindow
   hDC = GetDC(hWnd)

   With lf

      .lfHeight = -(m_Font.Size * GetDeviceCaps(hDC, LOGPIXELSY)) / 72
      .lfWidth = 0
      .lfEscapement = m_Rotation * 10
      .lfOrientation = .lfEscapement
      .lfWeight = m_Font.Weight
      .lfItalic = m_Font.Italic
      .lfUnderline = m_Font.Underline
      .lfStrikeOut = m_Font.Strikethrough
      .lfClipPrecision = CLIP_DEFAULT_PRECIS
      .lfQuality = PROOF_QUALITY
      .lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
      .lfFaceName = m_Font.Name & vbNullChar

      .lfCharSet = m_Font.Charset
      If .lfCharSet = OEM_CHARSET Then
         If (m_Rotation Mod 360) <> 0 Then
            .lfCharSet = ANSI_CHARSET
         End If
      End If

      If (m_Rotation Mod 360) <> 0 Then
         .lfOutPrecision = OUT_TT_ONLY_PRECIS
      Else
         .lfOutPrecision = OUT_DEFAULT_PRECIS
      End If
   End With

   CreateLogFont = CreateFontIndirect(lf)
   Call ReleaseDC(hWnd, hDC)
End Function

真的非常多谢你的回复，看来你非常了解API函数！你是API高手吧？

#7

lowxiong2013-03-05 00:16

　　曙光电子的代码有几个问题：1、只能转动文字，不能转动图片 2、转动时有闪烁 3、类模块里定义了几十种常数，只用了其中不到10个，代码太肥。
　　再就是拷贝曙光电子的代码，在窗体里添加所需控件后，还要做些小改动才能正常执行代码，第一处是在form_load事件里加 Timer1.Interval = 100：Timer1.Enabled=False,否则你勾选check1后也看不到字符循环转动，只能靠鼠标点击看到转动效果。第二处是在Form_Resize事件里将Check1.Left = Me.ScaleWidth - .Left - Check1.Width改成Check1.Left =0，否则我不管怎么摆控件都在窗体里找不到勾选项。
　　另外对不熟悉的朋友要提醒下：添加类模块，并把类取名为CLogFont，否则他无所适从的。

　　其实，如果不熟悉api调用，一样可以完成轮盘转动并得到随机结果的，方法是先用3dMax做一个3D的轮盘转动动画，渲染成一张张的动画图片系列，在vb中通过timer控件循环加载动画图片系列，一样可以看到转动的轮盘，并且还是立体动画。