Question

求一个VB程序代码，连连看的，谢谢

Answer 1

' '以下代码在 VB6 调试通过。
'一.将以下代码全部复制到窗体代码窗口内'以下代码在 VB6 调试通过。
'二.为窗体添加菜单
' 添加菜单 mFast，并为 mFast 添加子菜单 mmFast 和 mmTu
' 为 mmTu 添加子菜单 mmPic
' 将菜单 mmFast 和 mmPic 的索引设置为 0，其他属性不必设置。菜单结构如下：
' mFast
' ....mmFast 索引（index 属性）设置为 0
' ....mmTu
' ........mmPic 索引（index 属性）设置为 0
'三.在窗体中添加 7 个控件
' 4 个数组控件：Image1，Shape1，Label1，Line1，并将这四个控件的 Index 属性设置为 0
' 3 个单独控件：Picture1，Dir1，Timer1，都不用设置任何属性
'四.默认使用系统图标图案，如果要使用自己设置的图片（Ico文件），在工程所在目录下新建一个文件夹 Tu ，
' 在 Tu 下可建立多个文件夹，如“国旗”、“交通标准”等，然后将相应图标文件
' 放到其中，每个文件夹可放置 100 个文件。

Private Type tyTu
ImageNum As Integer 'Image 控件序号
Tu As Long '图片序号
Visible As Boolean '是否可见
End Type
Enum enTo
to_Up
to_Down
to_Left
to_Right
End Enum
Enum enTai
tai_Stop
tai_Play
tai_Auto
tai_Step
End Enum
Dim ctTu() As tyTu, ctH As Long, ctL As Long, ctGD() As Long, ctGDs As Long, ctBusy As Boolean '忙
Dim ctPicMax As Long, ctPicS As Long, ctPic() As Picture, ctNotePic() As String, ctSeBack() As Long
Dim ctTuType As String, ctSize As Long, ctX As Long, ctY As Long, ctTai As enTai
Dim ctHide() As Long, ctHideS As Long, ctStep As Long, ctStr As String, ctRefresh As Boolean
Dim ctMaxGD As Long, ctFen As Long, ctLife As Long, ctNote As Long
Dim ctFlashCi As Long, ctWait As Boolean, ctExit As Boolean
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
Private Function GetIcoToZu(nIco As String, Optional ReRead As Boolean) As Long
'提取图片，存入 ctPic()，并设置 ctNotePic()
Static UpIco As String
Dim F As String, S As Long, IcoID As Long, dl As Long, nPicS As Long
Dim nL As Long, nT As Long, pW As Long, pH As Long, nW As Long, nH As Long
Dim nPath As String, I As Long

If ReRead Then UpIco = "" '无条件重新读取图片文件
If UpIco = nIco Then GetIcoToZu = UBound(ctPic): Exit Function
UpIco = nIco

pW = Picture1.ScaleX(ctSize, Picture1.ScaleMode, 3) '转为像素
pH = Picture1.ScaleY(ctSize, Picture1.ScaleMode, 3) '转为像素
nW = 32: nH = 32
If pW < 32 Then nW = pW
If pH < 32 Then nH = pH

ReDim ctPic(1 To 1): ReDim ctNotePic(1 To 1)
Picture1.Move 0, 0, ctSize, ctSize
Picture1.Picture = LoadPicture()