标题:《奥运邮集》软件代码介绍——VB6初学之友
只看楼主
wangtuan7788
Rank: 1
等 级:新手上路
帖 子:286
专家分:0
注 册:2007-10-8
得分:0 
回复 39# 的帖子
你这里也可以用上面的方法啊,用一个循环把所有页面都关了啊

你笑我和你们不一样,我笑你们大家都一样~
2008-05-11 09:42
jrs123
Rank: 2
等 级:论坛游民
威 望:1
帖 子:627
专家分:14
注 册:2006-9-5
得分:0 
软件整体退出用的几组代码
***软件整体退出——整体退出需要返回到“主页面”,可以通过三个钮来实现,见图。代码如下:
'整体退出声明
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
Private bQuestion As Boolean
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) '从窗体关闭钮用此段
    If UnloadMode = 0 Then bQuestion = True
End Sub
Private Sub Command1_Click() '“退出系统”钮用此段
bQuestion = True
    Unload Me
End Sub
Private Sub cdtc_Click() '菜单栏上“退出系统”钮用此段
bQuestion = True
    Unload Me
End Sub
Private Sub Form_Unload(Cancel As Integer) '关闭钮共用部分
     If bQuestion Then
        If MsgBox("您确实要退出《奥林匹克运动会邮票集》吗?", 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
     Dim i As Integer '循环关闭各窗体用
For i = 1 To 30 '有几届n就写几届
   strWinName = "第" & i & "届"
   hLong = FindWindow(vbNullString, strWinName)
   If hLong Then
   GetWindowThreadProcessId hLong, LpID
   Ltem = OpenProcess(PROCESS_TERMINATE, False, LpID)
   TerminateProcess Ltem, 0
   hLong = 0
   End If
Next
strWinName = "olp" '关闭“悬浮窗体”用
hLong = FindWindow(vbNullString, strWinName)
If hLong Then
GetWindowThreadProcessId hLong, LpID
Ltem = OpenProcess(PROCESS_TERMINATE, False, LpID)
TerminateProcess Ltem, 0
hLong = 0
End If
End Sub

系统退出.JPG (73.82 KB)
2008-05-11 17:23
jrs123
Rank: 2
等 级:论坛游民
威 望:1
帖 子:627
专家分:14
注 册:2006-9-5
得分:0 
软件的多工程结构”小结
本讲“七、《奥运邮集》软件的多工程结构”小结:
   应知:(1)单工程和多工程的软件结构各有什么特点?何时采用单工程、何时采用多工程结构?
         (2)在多工程软件exe窗体之间的转换与工程内的窗体之间转换代码有何不同之处?
   应会:(1)单工程系统退出代码(含该工程所有窗体的进程退出);
         (2)多工程系统退出代码(含所有工程的进程退出);
   实践:请您也设计一个(单工程或多工程)系统退出代码,要求能弹出系统询问框的(参见上一帖的图例);
2008-05-13 13:04
jrs123
Rank: 2
等 级:论坛游民
威 望:1
帖 子:627
专家分:14
注 册:2006-9-5
得分:0 
下拉式悬浮窗代码介绍
八、悬浮窗体的功能与代码
      奥运邮集有夏季29届、冬季20届,因为需要向用户提供一个友好的、操作方便的换届方式。为此,偶在奥运邮集软件中采用了几种不同的窗体切换方式:
    1、主页上的菜单——即通过主页上的菜单(见图a1-tp3)。打开任一届奥运邮集。该方式的特点是,通过该菜单可以连续打开各届奥运邮集;
    2、各届奥运邮集的换页钮和换届钮——该方式的特点是:
    (1)可以连续打开本届各页邮票或相邻届的奥运邮集的第一页;
    (2)点击窗体右上角的关闭钮,可单独关闭该窗体;
    (3)点击退出本届奥运邮集时,可同时关闭本届所有已打开的窗体;(注:这组代码上面39楼已介绍过了)
    3、采用隐藏在屏幕左边的悬浮窗体切换各届奥运邮集——这一方式的特点是打开一届,即关闭已打开的其余各届(注:此代码上面31楼已介绍过了);
    下面,向大家介绍一组下拉式悬浮窗的代码:(悬浮窗隐藏在屏幕上方:)
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal ptx As Long, ByVal pty As Long) As Long
Private 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
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal X As Long, _
    ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Const HWND_TOPMOST = -1
Private Type POINTAPI
        X As Long
        Y As Long
End Type
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
     End Type
Private Is_Move_B As Boolean
Private Is_Movestar_B As Boolean
Private MyRect As RECT
Private MyPoint As POINTAPI
Private Movex As Long, Movey As Long
Private max As Long
Private Sub Form_Load()
        Timer1.Interval = 50: Timer2.Interval = 1000
        Form1.BackColor = vbBlue
        Get_Windows_Rect
        Picture1.Width = 10700
        Form1.Width = 10770
     End Sub
Sub Get_Windows_Rect()
        Dim dl&
        max = 2200: Form1.Height = max '窗体高度调整
        Form1.Top = 0
        dl& = GetWindowRect(Form1.hwnd, MyRect)
        End Sub
Private Sub Form_Paint()
        If PtInRect(MyRect, MyPoint.X, MyPoint.Y) = 0 Then
             SetWindowPos Me.hwnd, HWND_TOPMOST, Me.Left / Screen.TwipsPerPixelX, _
                  Me.Top \ Screen.TwipsPerPixelY, Me.Width \ Screen.TwipsPerPixelX, _
                  Form1.Height \ Screen.TwipsPerPixelY, 0
        End If
End Sub
Private Sub Timer1_Timer()
       Dim dl&
       dl& = GetCursorPos(MyPoint)
           If (PtInRect(MyRect, MyPoint.X, MyPoint.Y) And _
                     Form1.Height = max) Or MyPoint.Y <= 30 Then
                         Form1.BackColor = vbBlue
                Form1.Height = max
                         If MyPoint.X - MyRect.Left <= 10 Or Is_Movestar_B Then
                   Screen.MousePointer = 15
                   Is_Move_B = True
                Else
                   Screen.MousePointer = 0
                   Is_Move_B = False
          End If
                Else
               If Not Is_Movestar_B Then
                  Form1.Height = 30
               End If
            End If
 End Sub

a1-tp3.jpg (109.85 KB)
2008-05-14 17:56
jrs123
Rank: 2
等 级:论坛游民
威 望:1
帖 子:627
专家分:14
注 册:2006-9-5
得分:0 
鼠标滚轮放大缩小代码
九、窗体中的邮票
   历届奥运会邮票有着不同的发行年代,不同的题材和不同的风格以及不同的价值。而奥运邮集软件除了体现这些内容外,还要在邮票的观赏性方面有突出的表现。为此,本邮集除了选用了全新的邮票外,所有邮票提供放大缩小的功能以满足用户对观赏性方面的要求;
    1、邮票的放大缩小方法之一——用鼠标拖动图片边框或角来放大缩小单枚或整组邮票;要求在拖放中,邮票不变形(即高宽比例不变)代码如下:
Dim x0, y0 As Long
Sub form_initialize()
    x0 = Me.Width
    y0 = Me.Height
End Sub
Sub Form_Load()
Dim itemx As Object
    For Each itemx In Form1
        itemx.Tag = itemx.Left & "," & itemx.Top & "," & itemx.Width & "," & itemx.Height
    Next
End Sub
Sub form_resize()
Dim itemx As Object
    For Each itemx In Form1
        itemx.Move Split(itemx.Tag, ",")(0) * Me.Width / x0, Split(itemx.Tag, ",")(1) * Me.Width / x0, Split(itemx.Tag, ",")(2) * Me.Width / x0, Split(itemx.Tag, ",")(3) * Me.Width / x0
    Next
End Sub
    2、如果要求用鼠标滚轮也能操作邮票放大缩小,还需要添加一个模块,代码如下:
Option Explicit
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal Hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const GWL_WNDPROC = (-4)
Private Const WM_GETTEXT = &HD
Private Const WM_MOUSEWHEEL = &H20A
Dim theForm As Form
Dim PrevWndProc As Long
Public Function SubWndProc(ByVal Hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next      
    Select Case MSG   
    Case WM_MOUSEWHEEL
        With theForm
            If wParam > 0 Then
                .Height = .Height + .Height * 0.2      
                .Width = .Width + .Width * 0.2
            ElseIf wParam < 0 Then
                .Height = .Height - .Height * 0.2
                .Width = .Width - .Width * 0.2
            End If
        End With
    End Select
    SubWndProc = CallWindowProc(PrevWndProc, Hwnd, MSG, wParam, lParam)   
End Function
Public Function SetSubClass(ByVal FormObject As Form)
    Set theForm = FormObject
    PrevWndProc = SetWindowLong(theForm.Hwnd, GWL_WNDPROC, AddressOf SubWndProc)
End Function
Public Function UnSubClass()
    On Error Resume Next            
    SetWindowLong theForm.Hwnd, GWL_WNDPROC, PrevWndProc   
End Function

[[it] 本帖最后由 jrs123 于 2008-5-16 12:28 编辑 [/it]]
2008-05-16 09:12
jrs123
Rank: 2
等 级:论坛游民
威 望:1
帖 子:627
专家分:14
注 册:2006-9-5
得分:0 
十、页面中的文字说明
在窗体中有以下几种文字说明:
    1、留言式的奥运问答题——单击文字框,在弹出的文字输入框,在此框内可输入答案(见图)。该方案代码由二部分组成:
    '第一部分:
    Private Sub Form_Load()
    Text1.Text = GetSetting("MyApp101", "保存留言", "内容", "")
    Text2.Text = GetSetting("MyApp102", "保存留言", "内容", "")
    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 "MyApp101", "保存留言", "内容", myValue
    End If
   End Sub
提示:每个留言框有自己的代号,如MyApp101、 MyApp102等,二组代码的代号要一致。

[[it] 本帖最后由 jrs123 于 2008-5-21 07:05 编辑 [/it]]

留言框.JPG (21.34 KB)
2008-05-20 19:19
jrs123
Rank: 2
等 级:论坛游民
威 望:1
帖 子:627
专家分:14
注 册:2006-9-5
得分:0 
2、奥运简介——这是拖出Label文字框后将文字输入到属性中的Caption栏中。(页面上的“趣文”、“标题”也都是用这种方式。)
    当鼠标移到该文字框上,会出现一行文字提示,如“点击此栏更详细”,是Label文字框属性ToolTipText,将文字输入到栏内即可。
    此外,当鼠标点击该栏,还会弹出更详细的说明窗体(见图),这是由下面代码来实现的。如编辑时,双击“奥运简介”文字栏,光标跑到下面的代码上:
    Private Sub Label4_Click() '单击Label4事件;
    Load xj1sm '弹出xj1sm窗体(见图)
    xj1sm.Show
    End Sub
    “奥运简介”框是拖出Text1框,此框的属性可以决定以下几个内容:(见图)
    框内字体字型与字号选择属性——Font
    框内底色属性——Color
    框内字体颜色——ForeColor

[[it] 本帖最后由 jrs123 于 2008-6-15 09:37 编辑 [/it]]

页面上的文字说明.jpg (142.88 KB)


text1框属性.jpg (77.3 KB)
2008-05-22 13:41
jrs123
Rank: 2
等 级:论坛游民
威 望:1
帖 子:627
专家分:14
注 册:2006-9-5
得分:0 
抓图软件HyperSnap-DX
在制作《奥运邮集》软件过程中采用了几个软件,今将抓图软件介绍如下,因有的软件过大(5.82M)无法上传,需要的请留信箱;
    抓图软件HyperSnap-DX简介: (有注册机)
    HyperSnap-DX 是个有名的屏幕抓图工具(见图),它不仅能抓住标准桌面程序还能抓取 DirectX, 3Dfx Glide 游戏和视频或 DVD 屏幕图。
    本程序能以 20 多种图形格式(包括:BMP, GIF, JPEG, TIFF, PCX 等)保存并阅读图片。可以用热键或自动记时器从屏幕上抓图。
    功能还包括:在所抓的图像中显示鼠标轨迹,收集工具,有调色板功能并能设置分辨率,还能选择从 TWAIN 装置中(扫描仪和数码相机)抓图。
    ---== HyperSnap-DX v5.20.01 汉化注册版安装提示 ==---
    1:解压后运行HS5Setup52001.exe安装原版程序;
    2:再运行HB-HysnapDx52001-NW.exe安装汉化补丁。
    3:内附KeyGen.exe为注册机:
    注册提示:(也可按"注册全攻略"的示图提示进行注册)
    1:要选择“Purchase single licenses”--Next 才可获得您的机器码
    2:复制机器码到注册机,得到注册码后复制注册完成:)wdte

抓图软件000.jpg (66.66 KB)
2008-05-24 18:47
jrs123
Rank: 2
等 级:论坛游民
威 望:1
帖 子:627
专家分:14
注 册:2006-9-5
得分:0 
将bmp图像格式转换为jpg或GIF格式图像保质量
介绍Macromedia Fireworks V8.0软件(有注册机)
    数码相机拍摄的图片或用抓图软件抓取高质量的图片,通常为bmp格式,其容量常在1M以上,有没有能将其容量压缩而不降低图像质量的方法呢?
    偶找到了Macromedia Fireworks V8.0软件,方法很简单,见图。将bmp图像格式转换为其它格式(如jpg或gif)压缩容量而不降低图像质量;
    该软件自身rar容量达88M,在此无法上传,请见谅!想要的请留信箱
 十一、子窗体的结构
    《奥运邮集》软件的子窗体有以下几种不同结构格式;(见下图)
    1、带圆角的子窗体——在子窗体内形成窗体圆角用下面一组代码:
    Option Explicit
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3

As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal Hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Sub Form_Load()
    Dim hr As Long
    Dim dl As Long
    Dim usew As Long
    Dim useh As Long
    usew = Me.Width / Screen.TwipsPerPixelX
    useh = Me.Height / Screen.TwipsPerPixelY
    hr = CreateRoundRectRgn(0, 0, usew, useh, 80, 80)
    dl = SetWindowRgn(Me.Hwnd, hr, True)
End Sub
    2、带滚动条的文字框控件TextBox——当文字框内的文字较多时,可以通过滚动条看到全文。设置步骤如下:
    第一步:在窗体中拖出TextBox大小适中的文字框;(见带圆角的子窗体图中的“文字框”)
    第二步:在TextBox的属性中,MultiLine设为Ture(多行显示);ScrollBars设为2-Vertical(垂直滚动条);
    第三步:点击属性“Text”,在打开的框内粘贴上(输入)文字内容;
    第四步:通过属性“Font”设置字号与字体,“ForeColor”设置字体的颜色;
    3、可用鼠标滚轮放大缩小的窗体(见鼠标滚轮放大缩小窗体图)——关于鼠标滚轮事件的代码前面(45#)已经介绍过了,这里不再重复。

[[it] 本帖最后由 jrs123 于 2008-5-30 11:48 编辑 [/it]]

任选转换格式.jpg (11.48 KB)


带圆角子窗体.jpg (113.54 KB)
2008-05-27 06:58
jrs123
Rank: 2
等 级:论坛游民
威 望:1
帖 子:627
专家分:14
注 册:2006-9-5
得分:0 
十二、发布信息、登陆网站与QQ交谈
1、软件发布信息——就是在软件上设一个能向用户发送信息的文字框。
    偶在《奥运邮集》的主页面的右下角有个信息发布小窗体(见图1),以及在每一届的第一页上都有一个“最新信息”发布栏(见图2)。
    制作方法如下:
   (1)先添加Mirosoft Internet Transfer Control 6.0 (sp6)控件
   (2)若是固定的文字框,即在窗体上拖出Text1文字框,其属性:
        ScrollBars取2-Vertial(垂直滚动条);
        MultiLine取True(多行显示)
        Locked取True(锁定文字)
   (3)代码:(放在:Private Sub Form_Load()内)
        Text6.Text = Inet1.OpenURL("http://www.) <!--将各届所有的新信息txt文件都放在XX文件夹内-->
重要提示:在页面上要拖出Inet控件!(见图)

[[it] 本帖最后由 jrs123 于 2008-6-15 12:22 编辑 [/it]]

右下角信息框.jpg (8.15 KB)


信息发布框.jpg (18.44 KB)


信息发布控件.jpg (9.78 KB)
2008-05-30 09:57



参与讨论请移步原网站贴子:https://bbs.bccn.net/thread-203505-1-1.html




关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.267137 second(s), 8 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved