【VB】某科学超电磁炮（入门向）
其中的文字是可以改变的，比如“とある科学の超电磁炮”“とある定時の超級冒泡”“とある特別の作死技巧”，修改文本框的文本就能看到其中的文字发生改变。
此外颜色也可以修改的，点左下角的两个按钮就可以改变颜色了。点“宋体”按钮还可以改变字体。但是我拖拉Label控件的时候就是针对宋体进行修改的，改成别的字体不一定好看。
产生图片后，点“存储”就能将其保存为24位色的BMP。鼠标点击图片然后按下Ctrl+C就能直接复制图像到剪贴板，然后就能在QQ的聊天窗口里按Ctrl+V粘贴，就能发送了。是不是很方便？
这个程序是用VB写的。入门向的程序。代码很简单。
其实重点在于它对CreateObject这个VB函数的使用。VB使用这个函数进行COM类的使用。对于这个函数的资料一般不多，因为我们可以用别的方式达到目的，比如用API，或者换别的语言编程等。然而研究VB的这个还是比较有意义的——能更好地使用VB了。相比较而言使用API会略微降低代码可读性。
这里放出部分代码示例。大家可以看到CreateObject还是相当方便的——就是没有自动提示功能令人厌烦！不过MSDN都能找到资料。
公用文件对话框：Dim DlgObj As Object
Set DlgObj = CreateObject("MSComDlg.CommonDialog")
DlgObj.Filter = "24位BMP位图(*.bmp)|*.bmp|显示所有文件(*.*)|*.*" '文件扩展名，用|隔开，一般是“提示|扩展名|提示|扩展名|提示|扩展名……”等方式。
DlgObj.ShowSave '如果是打开文件就用ShowOpen，如果是保存文件就用ShowSave
If Len(DlgObj.FileName) Then MsgBox "保存到" & DlgObj.FileName公用字体对话框：Dim DlgObj As Object
Set DlgObj = CreateObject("MSComDlg.CommonDialog")
DlgObj.FontName = cmdFont.Caption
DlgObj.ShowFont
MsgBox "字体：" & DlgObj.FontName
MsgBox "是否斜体：" & DlgObj.FontItalic
MsgBox "是否粗体：" & DlgObj.FontBold
MsgBox "是否下划线：" & DlgObj.FontUnderline公用颜色对话框：Dim DlgObj As Object
Set DlgObj = CreateObject("MSComDlg.CommonDialog")
DlgObj.Color = cmdColor1.BackColor
DlgObj.ShowColor
MsgBox "颜色值：" & Hex$(DlgObj.Color)其实我喜欢VB的一个地方就是——它一般不使用方括号用作表达式，而是用圆括号，因此在发帖的时候就不会因为方括号导致论坛解析帖子内容出现BUG。典型的例子是C语言经常出现“［i］”这种使用数组元素的方式，对于论坛这是“斜体”（［i］中间是斜体内容［/i］）就会导致帖子很不好看。。
但是从各种方面来说C的可读性、可移植性和灵活性都很高。但是我一般不会使用C语言写这样的程序，因为嫌麻烦。
源代码：VERSION 5.00
Begin VB.Form frmMain
BorderStyle = 1'Fixed Single
Caption = "某科学超电磁炮"
ClientHeight = 3855
ClientLeft = 45
ClientTop = 375
ClientWidth = 4095
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 257
ScaleMode = 3'Pixel
ScaleWidth = 273
StartUpPosition = 3'窗口缺省
Begin VB.CommandButton cmdSave
Caption = "存储(&S)"
Height = 495
Left = 2520
TabIndex = 19
Top = 3240
Width = 1455
End
Begin VB.CommandButton cmdFont
Caption = "宋体"
Height = 495
Left = 1320
TabIndex = 18
Top = 3240
Width = 1095
End
Begin VB.CommandButton cmdSetOrgText
Caption = "恢复原始文本(&R)"
Height = 375
Left = 2280
TabIndex = 17
Top = 240
Width = 1695
End
Begin VB.CommandButton cmdColor2
BackColor = &H8000000D&
Height = 495
Left = 720
Style = 1'Graphical
TabIndex = 16
Top = 3240
Width = 495
End
Begin VB.CommandButton cmdColor1
BackColor = &H80000005&
Height = 495
Left = 120
Style = 1'Graphical
TabIndex = 15
Top = 3240
Width = 495
End
Begin VB.TextBox Text2
Height = 270
Left = 120
TabIndex = 14
Text = "Railgun"
Top = 720
Width = 3855
End
Begin VB.TextBox Text1
Height = 270
Left = 120
TabIndex = 13
Text = "とある科学の超电磁炮"
Top = 360
Width = 2055
End
Begin VB.PictureBox picPreview
BackColor = &H80000005&
Height = 2055
Left = 120
ScaleHeight = 133
ScaleMode = 3'Pixel
ScaleWidth = 253
TabIndex = 0
Top = 1080
Width = 3855
Begin VB.Label lblBottom
AutoSize = -1'True
BackStyle = 0'Transparent
Caption = "R a i l g u n"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 180
Left = 1320
TabIndex = 11
Top = 1770
Width = 1365
End
Begin VB.Label lblTexts
AutoSize = -1'True
BackStyle = 0'Transparent
Caption = "炮"
BeginProperty Font
Name = "宋体"
Size = 56.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1125
Index = 9
Left = 2640
TabIndex = 10
Top = 840
Width = 1125
End
Begin VB.Label lblTexts
AutoSize = -1'True
BackStyle = 0'Transparent
Caption = "磁"
BeginProperty Font
Name = "宋体"
Size = 48
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 960
Index = 8
Left = 1800
TabIndex = 9
Top = 840
Width = 960
End
Begin VB.Label lblTexts
AutoSize = -1'True
BackStyle = 0'Transparent
Caption = "电"
BeginProperty Font
Name = "宋体"
Size = 36
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 720
Index = 7
Left = 1200
TabIndex = 8
Top = 960
Width = 720
End
Begin VB.Label lblTexts
AutoSize = -1'True
BackColor = &H80000012&
Caption = "超"
BeginProperty Font
Name = "宋体"
Size = 48
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000005&
Height = 960
Index = 6
Left = 240
TabIndex = 7
Top = 960
Width = 960
End
Begin VB.Label lblTexts
AutoSize = -1'True
BackStyle = 0'Transparent
Caption = "の"
BeginProperty Font
Name = "宋体"
Size = 36
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 720
Index = 5
Left = 2880
TabIndex = 6
Top = 240
Width = 720
End
Begin VB.Label lblTexts
AutoSize = -1'True
BackStyle = 0'Transparent
Caption = "学"
BeginProperty Font
Name = "宋体"
Size = 36
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 720
Index = 4
Left = 2280
TabIndex = 5
Top = 240
Width = 720
End
Begin VB.Label lblTexts
AutoSize = -1'True
BackStyle = 0'Transparent
Caption = "科"
BeginProperty Font
Name = "宋体"
Size = 48
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 960
Index = 3
Left = 1380
TabIndex = 4
Top = 0
Width = 960
End
Begin VB.Label lblTexts
AutoSize = -1'True
BackStyle = 0'Transparent
Caption = "る"
BeginProperty Font
Name = "宋体"
Size = 27.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 555
Index = 2
Left = 1020
TabIndex = 3
Top = 120
Width = 555
End
Begin VB.Label lblTexts
AutoSize = -1'True
BackStyle = 0'Transparent
Caption = "あ"
BeginProperty Font
Name = "宋体"
Size = 36
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 720
Index = 1
Left = 600
TabIndex = 2
Top = 240
Width = 720
End
Begin VB.Label lblTexts
AutoSize = -1'True
BackStyle = 0'Transparent
Caption = "と"
BeginProperty Font
Name = "宋体"
Size = 56.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1125
Index = 0
Left = -120
TabIndex = 1
Top = -120
Width = 1125
End
End
Begin VB.Label lblText
AutoSize = -1'True
Caption = "文本："
Height = 180
Left = 120
TabIndex = 12
Top = 120
Width = 540
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'==============================================================================
'作者：0xAA55
'论坛：http://www.0xaa55.com/
'版权所有(C) 2013-2014 技术宅的结界
'请保留原作者信息，否则视为侵权
'------------------------------------------------------------------------------
Option Explicit
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
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 Sub Form_Load()
UpdateClr
End Sub
'更新颜色，使每个标签都使用设定的颜色
Sub UpdateClr()
lblBottom.ForeColor = cmdColor2.BackColor '小字的颜色
'大字的颜色
lblTexts(0).ForeColor = cmdColor2.BackColor
lblTexts(1).ForeColor = cmdColor2.BackColor
lblTexts(2).ForeColor = cmdColor2.BackColor
lblTexts(3).ForeColor = cmdColor2.BackColor
lblTexts(4).ForeColor = cmdColor2.BackColor
lblTexts(5).ForeColor = cmdColor2.BackColor
lblTexts(7).ForeColor = cmdColor2.BackColor
lblTexts(8).ForeColor = cmdColor2.BackColor
lblTexts(9).ForeColor = cmdColor2.BackColor
'图片框的颜色
picPreview.BackColor = cmdColor1.BackColor
'那个背景色和前景色颠倒的字“超”
lblTexts(6).ForeColor = cmdColor1.BackColor
lblTexts(6).BackColor = cmdColor2.BackColor
End Sub
'选取颜色1，背景色
Private Sub cmdColor1_Click()
Dim DlgObj As Object
Set DlgObj = CreateObject("MSComDlg.CommonDialog")
DlgObj.Color = cmdColor1.BackColor
DlgObj.ShowColor
cmdColor1.BackColor = DlgObj.Color
UpdateClr '选好颜色后更新那些字
End Sub
'选取颜色2，前景色
Private Sub cmdColor2_Click()
Dim DlgObj As Object
Set DlgObj = CreateObject("MSComDlg.CommonDialog")
DlgObj.Color = cmdColor2.BackColor
DlgObj.ShowColor
cmdColor2.BackColor = DlgObj.Color
UpdateClr
End Sub
'选取字体
Private Sub cmdFont_Click()
Dim DlgObj As Object
Set DlgObj = CreateObject("MSComDlg.CommonDialog")
DlgObj.FontName = cmdFont.Caption
DlgObj.ShowFont
cmdFont.Caption = DlgObj.FontName
Dim I&
For I = 0 To lblTexts.UBound
With lblTexts(I).Font
.Name = DlgObj.FontName
.Italic = DlgObj.FontItalic
.Bold = DlgObj.FontBold
.Underline = DlgObj.FontUnderline
End With
Next
End Sub
'双击小字的时候改变小字的字体
Private Sub lblBottom_DblClick()
Dim DlgObj As Object
Set DlgObj = CreateObject("MSComDlg.CommonDialog")
DlgObj.FontName = cmdFont.Caption
DlgObj.ShowFont
cmdFont.Caption = DlgObj.FontName
With lblBottom.Font
.Name = DlgObj.FontName
.Italic = DlgObj.FontItalic
.Bold = DlgObj.FontBold
.Underline = DlgObj.FontUnderline
End With
End Sub
'保存按钮
Private Sub cmdSave_Click()
Dim DlgObj As Object
Set DlgObj = CreateObject("MSComDlg.CommonDialog")
DlgObj.Filter = "24位BMP位图(*.bmp)|*.bmp|显示所有文件(*.*)|*.*"
DlgObj.ShowSave '显示保存对话框
If Len(DlgObj.FileName) Then SavePic DlgObj.FileName
End Sub
'恢复原始文本
Private Sub cmdSetOrgText_Click()
Text1.Text = "とある科学の超电磁炮"
Text2.Text = "Railgun"
End Sub
'图片框按下按键后复制图片到剪贴板
Private Sub picPreview_KeyDown(KeyCode As Integer, Shift As Integer)
If (Shift And 2) And KeyCode = vbKeyC Then
CopyPic
End If
End Sub
'这些字被点中的时候，把焦点设置给图片框，以便于接收Ctrl+C的按键
Private Sub lblTexts_Click(Index As Integer)
picPreview.SetFocus
End Sub
Private Sub lblBottom_Click()
picPreview.SetFocus
End Sub
'修改文本的时候显示效果
Private Sub Text1_Change()
On Error Resume Next
Dim I&, L&, T$
T = Text1.Text
L = Len(T)
For I = 0 To lblTexts.UBound
lblTexts(I).Caption = Mid$(T, I + 1, 1)
If I >= L Then Exit For
Next
End Sub
'这里是那行小字的显示
Private Sub Text2_Change()
On Error Resume Next
Dim I&, L&, T$, TSet$
T = Text2.Text
L = Len(T)
If L Then
For I = 0 To L
TSet = TSet & Mid$(T, I + 1, 1) & " " '每隔一个字符添加一个空格
Next
lblBottom.Caption = Left$(TSet, Len(TSet) - 1)
Else
lblBottom.Caption = ""
End If
End Sub
'保存图片
Sub SavePic(ByVal Path$)
picPreview.AutoRedraw = True '让图片框拥有后台缓冲区，这样就能使用VB自带的SavePicture保存图片了
Dim PrvDC As Long
PrvDC = GetDC(picPreview.hWnd) '表面的hDC
'将看到的内容画到图片框的后台缓冲区中
BitBlt picPreview.hdc, 0, 0, picPreview.ScaleWidth, picPreview.ScaleHeight, PrvDC, 0, 0, vbSrcCopy
ReleaseDC picPreview.hWnd, PrvDC
picPreview.Refresh '这行代码大概可有可无，刷新一下比较好
SavePicture picPreview.Image, Path '保存缓冲区的图片
picPreview.Cls
picPreview.AutoRedraw = False
picPreview.Cls
End Sub
'复制图片
Private Sub CopyPic()
picPreview.AutoRedraw = True
Dim PrvDC As Long
PrvDC = GetDC(picPreview.hWnd)
BitBlt picPreview.hdc, 0, 0, picPreview.ScaleWidth, picPreview.ScaleHeight, PrvDC, 0, 0, vbSrcCopy
ReleaseDC picPreview.hWnd, PrvDC
picPreview.Refresh
Clipboard.SetData picPreview.Image, vbCFBitmap
picPreview.Cls
picPreview.AutoRedraw = False
End SubBIN下载：
SRC下载： 标签过分了 科学超电磁炮是竖着的
魔法禁书目录是横着的
楼主大能，感谢感谢 卧槽，头一次知道可以用CreateObject的方式来调用公用对话框。
不过每次看到CreateObject就会想起ObCreateObject。
页:
[1]