《奥运邮集》软件代码介绍——VB6初学之友(页 3) - VB6论坛

wangtuan7788 发表于 2008-5-11 09:42

回复 39# 的帖子

你这里也可以用上面的方法啊，用一个循环把所有页面都关了啊

jrs123 发表于 2008-5-11 17:23

软件整体退出用的几组代码

***软件整体退出——整体退出需要返回到“主页面”，可以通过三个钮来实现，见图。代码如下：
'整体退出声明
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

jrs123 发表于 2008-5-13 13:04

软件的多工程结构”小结

本讲“七、《奥运邮集》软件的多工程结构”小结：
应知：（1）单工程和多工程的软件结构各有什么特点？何时采用单工程、何时采用多工程结构？
（2）在多工程软件exe窗体之间的转换与工程内的窗体之间转换代码有何不同之处？
应会：（1）单工程系统退出代码（含该工程所有窗体的进程退出）；
（2）多工程系统退出代码（含所有工程的进程退出）；
实践：请您也设计一个（单工程或多工程）系统退出代码，要求能弹出系统询问框的（参见上一帖的图例）；

jrs123 发表于 2008-5-14 17:56

下拉式悬浮窗代码介绍

八、悬浮窗体的功能与代码
   奥运邮集有夏季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

jrs123 发表于 2008-5-16 09:12

鼠标滚轮放大缩小代码

九、窗体中的邮票
历届奥运会邮票有着不同的发行年代，不同的题材和不同的风格以及不同的价值。而奥运邮集软件除了体现这些内容外，还要在邮票的观赏性方面有突出的表现。为此，本邮集除了选用了全新的邮票外，所有邮票提供放大缩小的功能以满足用户对观赏性方面的要求；
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]]

jrs123 发表于 2008-5-20 19:19

十、页面中的文字说明

在窗体中有以下几种文字说明：
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]]

jrs123 发表于 2008-5-22 13:41

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]]

jrs123 发表于 2008-5-24 18:47

抓图软件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

jrs123 发表于 2008-5-27 06:58

将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]]

jrs123 发表于 2008-5-30 09:57

十二、发布信息、登陆网站与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.jrs123.com/xx/xj1.txt") 
重要提示:在页面上要拖出Inet控件!(见图)

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

jrs123 发表于 2008-5-31 11:14

2、登陆网站——在软件上放一个按钮(或图片)，用户随时点击访问某个网站。提供两种方法供参考：
（1）第一种方法，就一句代码：Shell "explorer.exe http://www.jrs123.com" （这方法代码少而精，但不足的是登陆网站时，网站的页面是处于最小化状态，即在屏幕最下面的任务栏上）
（2）第二种方法：一个控件+一组声明+一组代码：（这个方法比较麻烦，但优点是登陆的网站是显示最大化页面，《奥运邮集》均采用这种方法）
'一个控件：向窗体内拖一个控件ComboBox并在属性属性Text中放进网址，如http://www.jrs123.com/(见图)
'一组声明：
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 Sub Command1_Click() '点击按钮1即登陆网站
Dim web As String '链接网站用,网址放在Combo1的属性Text中
web = Combo1.Text
ShellExecute 0&, vbNullString, web, vbNullString, vbNullString, 0
End Sub

jrs123 发表于 2008-6-3 10:23

窗体上设置与QQ交谈钮

3、与QQ交谈——这也有多种方法，下面介绍二种：
（1）第一种方法：（需加载 windows script host object model，见图,打开“工程”菜单,点“引用”）代码如下：
   Dim iw1 As New WshShell '声明
Private Sub command1_Click() '点击此钮与QQ交谈
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" '791465768是QQ号，jrs123是昵称
End If
End Sub
'判断是否安装QQ
Private Function getQQpath() As String
getQQpath = iw1.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Tencent\QQ\Install")
End Function
（2）第二种方法：加二个文件和一组代码。需要的二个文件（见下图），一组代码如下：
Private Sub Command1_Click() '点击此钮与QQ交谈
Dim TempName As String
TempName = App.Path & "\timwp tencent://message/?uin=791465768&Site=jrs123&Menu=yes"""
Shell TempName, vbHide
End Sub

jrs123 发表于 2008-6-5 11:46

生成免安装的绿色软件

十三、软件的形成与图标的制作
1、软件的形成：
由于奥运邮集各届都是生成exe文件格式，可独立运行的，而且所有控件都是VB6自带的，可以制作成不用安装的“绿色”exe软件。
各届exe文件的形成很简单，调试完成后，打开“文件”菜单，选“生成xj1.exe（K）”即可（见图）。
将各届的exe文件放在一个“奥运邮集”文件夹内，再将该文件夹压缩为“奥运邮集.rar”文件，就可以上传、下载了。

jrs123 发表于 2008-6-6 07:07

图标制作小软件与使用方法

2、图标的制作：
历届的奥运会是在不同的国家举办，所以图标可用各国的国旗，这里要用到的是一个制作图标软件（见附件）。下面向大家介绍该软件的使用方法：
（1）双击“图标生成器Version”，启动后如图1；
（2）用鼠标从旗子的左上右拖到右下角，放开鼠标键后弹出图2；
（3）点“导出”钮，弹出图3，若不作任何修改，就存盘；
（4）选图标格式：点存盘后弹出图4，一般选8位256色；
至此，完成了国旗图标的制作。

jrs123 发表于 2008-6-7 12:03

软件的新图标

3、exe选用新的图标：
有了新图标之后，从程序中调用它，形成exe文件后就有新图标了。具体方法如下：
（1）在窗体form1的属性中选中icon项，点击此项右边钮（见新图标1）；
（2）在弹出的新图标对话框中选一个图标（见新图标2），点打开后即完成新图标制作了；

jrs123 发表于 2008-6-7 12:25

《奥运邮集》软件全体成员

完成后的《奥运邮集》软件全体成员：

jrs123 发表于 2008-6-7 13:35

十四、软件的注册与加密原理

1、软件注册过程：
（1）用户ID号——《奥运邮集》的1-10届未加密，11-29届采取了加密措施，双击未注册的任一届（如第十一届）软件，会弹出软件注册框（见图1）。
在框内显示了“用户ID”号；
（2）注册机根据“用户ID号”——将用户ID号复制到注册机的相应框内，点击“获取注册码”钮，即在“注册码”框内出现该软件只有在该电脑上使用的注册码（见图2）。
（3）软件完成注册——将“注册码”放到图1的“注册码”框内，再点“注册”钮，即完成了该软件的注册。（只要注册一届，其余的不用再注册）
这种一台电脑一个注册码的方式称之为“电子注册”。若将注册后的软件再复制到另一台电脑上无法通用，而同样还需要另外注册的。

jrs123 发表于 2008-6-7 13:40

2、加密原理：

（1）加密原理：本软件是采用AES加密，这是一个高效快捷用于军事加密等级的类模块，可以在任何工程中使用。AES（128位字区大小，使用128、192或者256位密钥长度）原是用在美国政府进行保护机密（使用192或者256位密钥）和绝密文件的算法。不同于其他区段加密算法，AES是在VB中是最有效率的，因为加密一个区段能被使用唯一的CopyMemory，异或操作和一些位掩码；
（2）使用范围：本软件加密方式任何的程序都可以使用，只需将一个窗口模块和一个类模块加入，同时改一下密码钥匙就可以了；
（3）该加密方式，密码与电脑特征码绑定，实现了电子注册方式，即一台电脑一个注册码；

jrs123 发表于 2008-6-7 13:43

结束语

《奥运邮集》软件采用的代码介绍完了，作为软件本身还有许多不足之处，有待进一步改进。但作为向VB6初学者介绍这些代码，也只是提供一些“积木”而已，一些代码偶也是“知其然，不知其所以然”，缺少“注释”，请见谅。
作为一项软件产品，完成之后，就想对自己的权宜有所保护，所以采取了“加密”措施，这也是人之常情。当您看完这篇帖子之后，就会觉得这个加密是没必要了，所有的源码也不过如此。
欢迎到“奥运邮集”网站下载全套软件，提出您的宝贵意见！

2008年是北京奥运年。北京加油，中国加油！

[[it] 本帖最后由 jrs123 于 2008-6-9 08:35 编辑 [/it]]

fsxs 发表于 2008-6-10 23:27

是在佩服楼主的勇气和毅力

花了2年时间完成了自己的心愿

我搜索了楼主所发表的帖子，从初始VB到现在完成自己的杰作，太让人佩服了！

我也是学机械的，VB也是自学的，刚过了2级，希望也能像楼主一样编出自己自豪的软件。

LZ我加你QQ了，以后还多多指教啊
我QQ：240071719 jln

页: 1 2 [3] 4