这页的全部代码:就是想将音乐换成视频;
'关闭前面的窗体用
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Const PROCESS_TERMINATE = 1
'下面是链接网站用代码(一共有两个部分,第2段见下面Command4)
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_SHOW = 5
Private bQuestion As Boolean '关闭钮用1222
Dim iw1 As New WshShell 'QQ对话用(3-1)
'需加载 windows script host object model
'以下二级菜单
Private Declare Function GetMenu Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function SetMenuItemBitmaps Lib "user32" _
(ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, _
ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Const MF_BYPOSITION = &H400&
'Private Sub Form_Unload(Cancel As Integer) '二级菜单用
'Unload FrmMenu
'End Sub
Private Sub frame1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) '二级菜单用
If Button And vbRightButton Then
PopupMenu FrmMenu.jrswj
End If
End Sub
Private Sub tp8_Click() '二级菜单用
End
End Sub
Private Sub Command4_Click()
WindowsMediaPlayer1.URL = App.Path + "/mi/kk.avi"
WindowsMediaPlayer1.settings.playCount = &H7FFFFFFF '上一首连续播放
Command9.Visible = True '换钮
Command4.Visible = False
End Sub
Private Sub Command9_Click() '停止播放
WindowsMediaPlayer1.Close
Command9.Visible = False '换钮
Command4.Visible = True
End Sub
Private Sub Command8_Click() 'QQ对话用(3-2)
On Error Resume Next
If getQQpath = "" Then
MsgBox "你没有安装QQ,请先安装QQ", vbOKOnly Or vbInformation, Me.Caption
Exit Sub
Else
iw1.Run "tencent://message/?uin=791465768&Site=jrs123&Menu=yes"
End If
End Sub
'判断是否安装QQ 'QQ对话用(3-3)
Private Function getQQpath() As String
getQQpath = iw1.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Tencent\QQ\Install")
End Function
Private Sub Command7_Click()
Dim web As String '链接网站用,网址放在Combo1的属性Text中
web = Combo1.Text
ShellExecute 0&, vbNullString, web, vbNullString, vbNullString, 0
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) '关闭钮用1222
'If UnloadMode = 0 Then bQuestion = True
End Sub
Private Sub Command10_Click()
Load xj15009b
xj15009b.Show
End Sub
Private Sub Command11_Click()
Dim web As String '链接网站用,网址放在Combo1的属性Text中
web = Combo2.Text
ShellExecute 0&, vbNullString, web, vbNullString, vbNullString, 0
End Sub
Private Sub Command16_Click()
Dim Ltem As Long
Dim LpID As Long
Dim hLong
As Long
Dim strWinName
As String
strWinName = "奥林匹克运动会邮票集"
hLong = FindWindow(vbNullString, strWinName)
If hLong Then
GetWindowThreadProcessId hLong, LpID
Ltem = OpenProcess(PROCESS_TERMINATE, False, LpID)
TerminateProcess Ltem, 0
hLong = 0
End If
Shell "rundll32.exe url.dll,FileProtocolHandler " & App.Path & "\olpk.exe", vbMaximizedFocus
bQuestion = False '关闭钮用(3)
'Unload Me
End Sub
Private Sub Command2_Click()
Shell "rundll32.exe url.dll,FileProtocolHandler " & App.Path & "\xj14.exe", vbMaximizedFocus
bQuestion = False '关闭钮用1222
'Unload Me
End Sub
Private Sub Command3_Click()
Shell "rundll32.exe url.dll,FileProtocolHandler " & App.Path & "\xj16.exe", vbMaximizedFocus
bQuestion = False '关闭钮用1222
'Unload Me
End Sub
Private Sub Command5_Click()
Shell "rundll32.exe url.dll,FileProtocolHandler " & App.Path & "\xj14.exe", vbMaximizedFocus
bQuestion = False '关闭钮用1222
'Unload Me
End Sub
Private Sub Command6_Click()
Shell "rundll32.exe url.dll,FileProtocolHandler " & App.Path & "\xj16.exe", vbMaximizedFocus
bQuestion = False '关闭钮用1222
'Unload Me
End Sub
Private Sub Image1_Click()
Load xj1501
xj1501.Show
End Sub
Private Sub Image2_Click()
Load xj1502
xj1502.Show
End Sub
Private Sub Image20_Click()
Load xj1505
xj1505.Show
End Sub
Private Sub Image21_Click()
Load xj1506
xj1506.Show
End Sub
Private Sub Image3_Click()
Load xj1503
xj1503.Show
End Sub
Private Sub Image4_Click()
Load xj1504
xj1504.Show
End Sub
Private Sub Image9_Click()
Load xj15001
xj15001.Show
End Sub
Private Sub Image6_Click()
Load xj15002a
xj15002a.Show
End Sub
Private Sub Image5_Click()
Load xj15001
xj15001.Show
End Sub
Private Sub Image11_Click()
Load xj15001
xj15001.Show
End Sub
Private Sub Image7_Click()
Load xj15001
xj15001.Show
End Sub
Private Sub Image10_Click()
Load xj15002a
xj15002a.Show
End Sub
Private Sub Image8_Click()
Load xj15001
xj15001.Show
End Sub
Private Sub Image12_Click()
Load xj15001
xj15001.Show
End Sub
Private Sub Image13_Click()
Load xj15009a
xj15009a.Show
End Sub
Private Sub Image14_Click()
Load xj15010a
xj15010a.Show
End Sub
Private Sub Image15_Click()
Load xj15001
xj15001.Show
End Sub
Private Sub Image16_Click()
Load xj15012a
xj15012a.Show
End Sub
Private Sub Image17_Click()
Load xj15013a
xj15013a.Show
End Sub
Private Sub Image19_Click()
Load xj15014a
xj15014a.Show
End Sub
Private Sub Image18_Click()
Load xj15001
xj15001.Show
End Sub
Private Sub Command1_Click()
Dim Ltem As Long
Dim LpID As Long
Dim hLong
As Long
Dim strWinName
As String
If MsgBox("你要退出《第15届奥运会邮票集》吗?", vbYesNo + vbExclamation, "系统询问") = vbYes Then
Unload Me
End
Else
Cancel = True
End If
'bQuestion = True '关闭钮用(6特)
退出系统,单页用此句代码
'Unload Me
End Sub
Private Sub Form_Load() '留言栏,注意MyApp编号
'Text6.Text = Inet1.OpenURL("http://www.)
Text1.Text = GetSetting("MyApp15a01", "保存留言", "内容", "") '留言栏用,有2个部分,下面还有对应的一部分
Text2.Text = GetSetting("MyApp15a02", "保存留言", "内容", "")
Text3.Text = GetSetting("MyApp15a03", "保存留言", "内容", "")
Text4.Text = GetSetting("MyApp15a04", "保存留言", "内容", "")
Text5.Text = GetSetting("MyApp15a05", "保存留言", "内容", "")
Hook Me.hwnd
End Sub
Private Sub form_resize() '滚动条与鼠标事件用
If Frame1.Height > Me.Height Then
VScroll1.Visible = True
Else
VScroll1.Visible = False
End If
If Frame1.Width > Me.Width Then
HScroll1.Visible = True
Else
HScroll1.Visible = False
End If
HScroll1.Left = 0
HScroll1.Top = Me.ScaleHeight - HScroll1.Height
VScroll1.Left = Me.ScaleWidth - VScroll1.Width
VScroll1.Top = 0
HScroll1.Width = Me.ScaleWidth
VScroll1.Height = Me.ScaleHeight
If VScroll1.Visible = True Then
If HScroll1.Visible = True Then
HScroll1.Width = Abs(Me.ScaleWidth - VScroll1.Width)
VScroll1.Height = Abs(Me.ScaleHeight - HScroll1.Height)
End If
End If
HScroll1.Max = (Frame1.Width - Me.Width) + 3 * VScroll1.Width
VScroll1.Max = (Frame1.Height - Me.Height) + 3 * HScroll1.Height
HScroll1.ZOrder
VScroll1.ZOrder
Frame1.Left = (Me.ScaleWidth - Frame1.Width) / 2
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim Ltem As Long
Dim LpID As Long
Dim hLong As Long
Dim pForm As Form
Const strWinName As String = "第15届"
If bQuestion Then
If MsgBox("你要退出《第15届奥运会邮票集》吗?", vbYesNo + vbExclamation, "系统询问") <> vbYes Then
Cancel = True
Exit Sub
Else
hLong = FindWindow(vbNullString, strWinName)
If hLong Then
GetWindowThreadProcessId hLong, LpID
Ltem = OpenProcess(PROCESS_TERMINATE, False, LpID)
TerminateProcess Ltem, 0
hLong = 0
End If
End If
End If
UnHook Me.hwnd '鼠标滚轮事件用
For Each pForm In Forms
Unload pForm
Next
End Sub
Private Sub HScroll1_Change() '滚动条与鼠标事件用
Frame1.Left = -HScroll1.Value
End Sub
Private Sub Label12_Click()
Load xj15qw
xj15qw.Show
End Sub
Private Sub Label3_Click()
Load xj15sm
xj15sm.Show
End Sub
Private Sub VScroll1_Change() '滚动条与鼠标事件用
Frame1.Top = -VScroll1.Value
End Sub
Private Sub VScroll1_GotFocus()
Command1.SetFocus
End Sub
Private Sub Text1_Click()
Dim message, title, defaultValue As String
Dim myValue As String
message = ""
'设置提示信息
title = "请输入您的答案"
'设置标题
defaultValue = ""
'设置默认值
myValue = InputBox(message, title, defaultValue, 100, 100)
'显示输入对话框
If myValue = "" Then
Else
Text1.Text = myValue
SaveSetting "MyApp15a01", "保存留言", "内容", myValue
End If
End Sub
Private Sub Text2_Click()
Dim message, title, defaultValue As String
Dim myValue As String
message = ""
'设置提示信息
title = "请输入您的答案"
'设置标题
defaultValue = ""
'设置默认值
myValue = InputBox(message, title, defaultValue, 100, 100)
'显示输入对话框
If myValue = "" Then
Else
Text2.Text = myValue
SaveSetting "MyApp15a02", "保存留言", "内容", myValue
End If
End Sub
Private Sub Text3_Click()
Dim message, title, defaultValue As String
Dim myValue As String
message = ""
'设置提示信息
title = "请输入您的答案"
'设置标题
defaultValue = ""
'设置默认值
myValue = InputBox(message, title, defaultValue, 100, 100)
'显示输入对话框
If myValue = "" Then
Else
Text3.Text = myValue
SaveSetting "MyApp15a03", "保存留言", "内容", myValue
End If
End Sub
Private Sub Text4_Click()
Dim message, title, defaultValue As String
Dim myValue As String
message = ""
'设置提示信息
title = "请输入您的答案"
'设置标题
defaultValue = ""
'设置默认值
myValue = InputBox(message, title, defaultValue, 100, 100)
'显示输入对话框
If myValue = "" Then
Else
Text4.Text = myValue
SaveSetting "MyApp15a04", "保存留言", "内容", myValue
End If
End Sub
Private Sub Text5_Click()
Dim message, title, defaultValue As String
Dim myValue As String
message = ""
'设置提示信息
title = "请输入您的答案"
'设置标题
defaultValue = ""
'设置默认值
myValue = InputBox(message, title, defaultValue, 100, 100)
'显示输入对话框
If myValue = "" Then
Else
Text5.Text = myValue
SaveSetting "MyApp15a05", "保存留言", "内容", myValue
End If
End Sub