Слияние кода завершено, страница обновится автоматически
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} UserForm2
Caption = "CrelDRAW广告行业通用条幅制作器 v1.0"
ClientHeight = 11415
ClientLeft = 45
ClientTop = 375
ClientWidth = 17235
OleObjectBlob = "UserForm2.frx":0000
ShowModal = 0 'False
StartUpPosition = 2 '屏幕中心
End
Attribute VB_Name = "UserForm2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Copyright [2012-2019] [www.cdrvba.com]
'Licensed under the Apache License, Version 2.0 (the "License");
'you may not use this file except in compliance with the License.
'You may obtain a copy of the License at
' http://www.apache.org/licenses/LICENSE-2.0
'Unless required by applicable law or agreed to in writing, software
'distributed under the License is distributed on an "AS IS" BASIS,
'WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
'See the License for the specific language governing permissions and
'limitations under the License.
Option Explicit
Dim textArray(39) As String
Dim directionArray(2) As String
Dim lengthArray(10) As String
Dim widthArray(4) As String
Dim sdWidthArray(6) As String
Dim colorArray(2) As String
Dim numberArray(10) As String
Dim inscribeArray(5) As String
Const expireTime = "none" ' 设置为none表示永不过期，也可以设置为指定时间，例如：2017-01-01 00:00
'*****************************************************************************************************************************************************************************************************************************************
' 初始化随机数据
'*****************************************************************************************************************************************************************************************************************************************
Public Sub initTestData()
clearAll
textArray(0) = "教师教学的过程也是教师成长的过程"
textArray(1) = "勿以善小而不为 勿以恶小而为之"
textArray(2) = "坚持科学发展观 促进教育大发展"
textArray(3) = "今天我以武中为荣 明天武中以我为荣"
textArray(4) = "一个真正美的心灵总是有所作为而且是一个实实在在的人"
textArray(5) = "知识是进步的殿堂 互动学习是沟通心灵的桥梁"
textArray(6) = "教育就是服务 是学生的服务"
textArray(7) = "坚持科学发展观 促进教育大发展"
textArray(8) = "崇尚科学 追求真理 赤诚爱国 奋发成才"
textArray(9) = "书籍——进步的阶梯知识——力量的源泉"
textArray(10) = "多思是知识的钥匙 勤奋是知识的土壤"
textArray(11) = "为中华民族的富强、民主和文明艰苦创业、奋斗"
textArray(12) = "学习改变命运，教育决定未来，成就未来！"
textArray(13) = "让爱心伴我左右 让文明与你同行"
textArray(14) = "社会发展教育先行 教育振兴全民有责"
textArray(15) = "实施科教兴市战略 促进经济持续发展"
textArray(16) = "人生包括两个部分：过去的是一个梦；未来的是一个希望。"
textArray(17) = "书山有路勤为径 学海无涯苦作舟"
textArray(18) = "工作是生活核心 就业是民生之本 教育是立身之源"
textArray(19) = "创新是一个民族进步的灵魂 是一个国家兴旺发达的不竭动力"
textArray(20) = "办好人民满意教育 为全面建设小康社会作贡献"
textArray(21) = "完善终身教育体系 构建学习型社会"
textArray(22) = "百尺竿头须进步 十方世界是全身"
textArray(23) = "有志者，事竟成 ——《后汉书·耿弇传》"
textArray(24) = "在失败面前一百次感叹，不如一次实干"
textArray(25) = "勤能补拙是良训 一分辛劳一分才"
textArray(26) = "大力推进科教兴镇（市）战略 普遍提高广大农民群众的劳动素质"
textArray(27) = "世界上荣誉的桂冠 都用荆棘纺织而成"
textArray(28) = "书到用时方恨少 事非经过不知难"
textArray(29) = "学须静也，非淡泊无以明志，非宁静无以致远"
textArray(30) = "索菲亚衣柜恭祝新乡市九源商贸有限公司恒心有恒业 隆德享隆名"
textArray(31) = "同乐家居恭祝新乡市九源商贸有限公司永隆大业 昌裕后人"
textArray(32) = "公牛管业恭祝新乡市九源商贸有限公司生意似春笋 财源如春潮"
textArray(33) = "天久集团恭祝新乡市九源商贸有限公司宏图大展 裕业有孚"
textArray(34) = "圣德堡陶瓷恭祝新乡市九源商贸有限公司公平有德 和气致祥"
textArray(35) = "金银街恭祝新乡市九源商贸有限公司隆声援布 兴业长新"
textArray(36) = "张成瑶恭祝新乡市九源商贸有限公司生意如同春意满 财源更比流水长"
textArray(37) = "某公司恭祝新乡市九源商贸有限公司门迎晓日财源广 户纳春风喜庆多"
textArray(38) = "龙翔广告祝福新乡市九源商贸有限公司开业志禧"
directionArray(0) = "横向"
directionArray(1) = "竖向"
lengthArray(0) = "7.5"
lengthArray(1) = "8"
lengthArray(2) = "8.5"
lengthArray(3) = "9"
lengthArray(4) = "9.5"
lengthArray(5) = "10"
lengthArray(6) = "10.5"
lengthArray(7) = "11"
lengthArray(8) = "11.5"
lengthArray(9) = "12"
widthArray(0) = "440"
widthArray(1) = "540"
widthArray(2) = "670"
widthArray(3) = "820"
sdWidthArray(0) = "350"
sdWidthArray(1) = "360"
sdWidthArray(2) = "450"
sdWidthArray(3) = "460"
sdWidthArray(4) = "550"
sdWidthArray(5) = "560"
colorArray(0) = "白字"
colorArray(1) = "黄字"
numberArray(0) = "1"
numberArray(1) = "2"
numberArray(2) = "3"
numberArray(3) = "4"
numberArray(4) = "5"
numberArray(5) = "6"
numberArray(6) = "7"
numberArray(7) = "8"
numberArray(8) = "9"
numberArray(9) = "10"
inscribeArray(0) = "成都市金牛区政府 宣"
inscribeArray(1) = "欢迎访问个人博客 www.zebe.me"
inscribeArray(2) = "江苏市教育局 宣"
inscribeArray(3) = "攀枝花市林业局 宣"
inscribeArray(4) = "中华人才网"
End Sub
'*****************************************************************************************************************************************************************************************************************************************
' 返回空白落款或者随机落款文字
'*****************************************************************************************************************************************************************************************************************************************
Public Function getRndInscribe() As String
Dim r As Integer
Randomize
r = Rnd * 9
If r > 5 Then
getRndInscribe = inscribeArray(Rnd * UBound(inscribeArray))
Else
getRndInscribe = ""
End If
End Function
'*****************************************************************************************************************************************************************************************************************************************
' 生成随机数据
'*****************************************************************************************************************************************************************************************************************************************
Public Sub setRndText(num As Integer)
Randomize
If num >= 1 Then t1.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 2 Then t2.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 3 Then t3.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 4 Then t4.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 5 Then t5.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 6 Then t6.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 7 Then t7.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 8 Then t8.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 9 Then t9.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 10 Then t10.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 11 Then t11.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 12 Then t12.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 13 Then t13.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 14 Then t14.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 15 Then t15.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 16 Then t16.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 17 Then t17.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 18 Then t18.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 19 Then t19.text = textArray(Int(Rnd * UBound(textArray)))
If num >= 20 Then t20.text = textArray(Int(Rnd * UBound(textArray)))
End Sub
Public Sub setRndDirection(num As Integer)
Randomize
If num >= 1 Then d1.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 2 Then d2.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 3 Then d3.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 4 Then d4.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 5 Then d5.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 6 Then d6.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 7 Then d7.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 8 Then d8.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 9 Then d9.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 10 Then d10.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 11 Then d11.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 12 Then d12.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 13 Then d13.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 14 Then d14.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 15 Then d15.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 16 Then d16.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 17 Then d17.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 18 Then d18.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 19 Then d19.text = directionArray(Int(Rnd * UBound(directionArray)))
If num >= 20 Then d20.text = directionArray(Int(Rnd * UBound(directionArray)))
End Sub
Public Sub setRndColor(num As Integer)
Randomize
If num >= 1 Then c1.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 2 Then c2.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 3 Then c3.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 4 Then c4.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 5 Then c5.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 6 Then c6.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 7 Then c7.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 8 Then c8.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 9 Then c9.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 10 Then c10.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 11 Then c11.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 12 Then c12.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 13 Then c13.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 14 Then c14.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 15 Then c15.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 16 Then c16.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 17 Then c17.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 18 Then c18.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 19 Then c19.text = colorArray(Int(Rnd * UBound(colorArray)))
If num >= 20 Then c20.text = colorArray(Int(Rnd * UBound(colorArray)))
End Sub
Public Sub setRndLength(num As Integer)
Randomize
If num >= 1 Then l1.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 2 Then l2.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 3 Then l3.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 4 Then l4.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 5 Then l5.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 6 Then l6.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 7 Then l7.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 8 Then l8.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 9 Then l9.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 10 Then l10.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 11 Then l11.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 12 Then l12.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 13 Then l13.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 14 Then l14.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 15 Then l15.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 16 Then l16.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 17 Then l17.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 18 Then l18.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 19 Then l19.text = lengthArray(Int(Rnd * UBound(lengthArray)))
If num >= 20 Then l20.text = lengthArray(Int(Rnd * UBound(lengthArray)))
End Sub
Public Sub setRndWidth(num As Integer)
Randomize
If num >= 1 Then w1.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 2 Then w2.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 3 Then w3.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 4 Then w4.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 5 Then w5.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 6 Then w6.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 7 Then w7.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 8 Then w8.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 9 Then w9.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 10 Then w10.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 11 Then w11.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 12 Then w12.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 13 Then w13.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 14 Then w14.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 15 Then w15.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 16 Then w16.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 17 Then w17.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 18 Then w18.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 19 Then w19.text = widthArray(Int(Rnd * UBound(widthArray)))
If num >= 20 Then w20.text = widthArray(Int(Rnd * UBound(widthArray)))
End Sub
' 根据布料宽度获得正确的色带宽度
Public Function getSDWithByBuLiao(blWidth As String) As String
Select Case blWidth
Case "670", "820"
getSDWithByBuLiao = "550"
Case "440"
getSDWithByBuLiao = "350"
Case "540"
getSDWithByBuLiao = "450"
End Select
End Function
Public Sub setRndSDWith(num As Integer)
Randomize
If num >= 1 Then s1.text = getSDWithByBuLiao(w1.text)
If num >= 2 Then s2.text = getSDWithByBuLiao(w2.text)
If num >= 3 Then s3.text = getSDWithByBuLiao(w3.text)
If num >= 4 Then s4.text = getSDWithByBuLiao(w4.text)
If num >= 5 Then s5.text = getSDWithByBuLiao(w5.text)
If num >= 6 Then s6.text = getSDWithByBuLiao(w6.text)
If num >= 7 Then s7.text = getSDWithByBuLiao(w7.text)
If num >= 8 Then s8.text = getSDWithByBuLiao(w8.text)
If num >= 9 Then s9.text = getSDWithByBuLiao(w9.text)
If num >= 10 Then s10.text = getSDWithByBuLiao(w10.text)
If num >= 11 Then s11.text = getSDWithByBuLiao(w11.text)
If num >= 12 Then s12.text = getSDWithByBuLiao(w12.text)
If num >= 13 Then s13.text = getSDWithByBuLiao(w13.text)
If num >= 14 Then s14.text = getSDWithByBuLiao(w14.text)
If num >= 15 Then s15.text = getSDWithByBuLiao(w15.text)
If num >= 16 Then s16.text = getSDWithByBuLiao(w16.text)
If num >= 17 Then s17.text = getSDWithByBuLiao(w17.text)
If num >= 18 Then s18.text = getSDWithByBuLiao(w18.text)
If num >= 19 Then s19.text = getSDWithByBuLiao(w19.text)
If num >= 20 Then s20.text = getSDWithByBuLiao(w20.text)
End Sub
Public Sub setRndNumber(num As Integer)
Randomize
If num >= 1 Then n1.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 2 Then n2.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 3 Then n3.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 4 Then n4.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 5 Then n5.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 6 Then n6.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 7 Then n7.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 8 Then n8.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 9 Then n9.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 10 Then n10.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 11 Then n11.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 12 Then n12.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 13 Then n13.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 14 Then n14.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 15 Then n15.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 16 Then n16.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 17 Then n17.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 18 Then n18.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 19 Then n19.text = numberArray(Int(Rnd * UBound(numberArray)))
If num >= 20 Then n20.text = numberArray(Int(Rnd * UBound(numberArray)))
End Sub
Public Sub setInscribe(num As Integer)
Randomize
If num >= 1 Then k1.text = getRndInscribe()
If num >= 2 Then k2.text = getRndInscribe()
If num >= 3 Then k3.text = getRndInscribe()
If num >= 4 Then k4.text = getRndInscribe()
If num >= 5 Then k5.text = getRndInscribe()
If num >= 6 Then k6.text = getRndInscribe()
If num >= 7 Then k7.text = getRndInscribe()
If num >= 8 Then k8.text = getRndInscribe()
If num >= 9 Then k9.text = getRndInscribe()
If num >= 10 Then k10.text = getRndInscribe()
If num >= 11 Then k11.text = getRndInscribe()
If num >= 12 Then k12.text = getRndInscribe()
If num >= 13 Then k13.text = getRndInscribe()
If num >= 14 Then k14.text = getRndInscribe()
If num >= 15 Then k15.text = getRndInscribe()
If num >= 16 Then k16.text = getRndInscribe()
If num >= 17 Then k17.text = getRndInscribe()
If num >= 18 Then k18.text = getRndInscribe()
If num >= 19 Then k19.text = getRndInscribe()
If num >= 20 Then k20.text = getRndInscribe()
End Sub
Private Sub cboMainTextStyle_Change()
If cboMainTextStyle.text = "美观优先" Then
lblJX.Visible = True
cboJX.Visible = True
Else
lblJX.Visible = False
cboJX.Visible = False
End If
End Sub
Private Sub cmdAddTest_Click()
' 有内容时先询问
'If hasText() Then
'Dim c As Integer
'c = MsgBox("将会清空所有内容，然后设置测试数据，是否继续？", vbYesNo + vbInformation)
'If c = vbNo Then Exit Sub
'End If
' 清除数据并调用设置函数（必须最先设置文本，因为设置了事件关联）
initTestData
clearAll
Dim num As Integer
Randomize
num = (Rnd * 20) + 1
'num = 2
If num > 20 Then num = 20
setRndText (num)
setRndDirection (num)
setRndColor (num)
setRndLength (num)
setRndWidth (num)
setRndSDWith (num)
setRndNumber (num)
setInscribe (num)
End Sub
Private Sub cmdAbout_Click()
UserForm1.Show 1
End Sub
Private Sub cmdClear_Click()
If hasText() Then
' 清空前询问
Dim c As Integer
c = MsgBox("是否要清空全部内容？", vbYesNo)
If c = vbYes Then clearAll
Else
MsgBox "已经是清空状态！", vbInformation
End If
End Sub
'*****************************************************************************************************************************************************************************************************************************************
' 清空全部内容
'*****************************************************************************************************************************************************************************************************************************************
Public Sub clearAll()
t1.text = "": t2.text = "": t3.text = "": t4.text = "": t5.text = "":
t6.text = "": t7.text = "": t8.text = "": t9.text = "": t10.text = "":
t11.text = "": t12.text = "": t13.text = "": t14.text = "": t15.text = "":
t16.text = "": t17.text = "": t18.text = "": t19.text = "": t20.text = ""
End Sub
'*****************************************************************************************************************************************************************************************************************************************
' 检查是否输入了内容
'*****************************************************************************************************************************************************************************************************************************************
Public Function hasText() As Boolean
Dim t As String
t = t1.text + t2.text + t3.text + t4.text + t5.text + t6.text + t7.text + t8.text + t9.text + t10.text
t = t + t11.text + t12.text + t13.text + t14.text + t15.text + t16.text + t17.text + t18.text + t19.text + t20.text
t = Trim(t)
If t <> "" Then
hasText = True
Else
hasText = False
End If
End Function
'*****************************************************************************************************************************************************************************************************************************************
' 检查内容及参数是否合法
' 此函数同时累加要制作的合法条幅数量总计
'*****************************************************************************************************************************************************************************************************************************************
Public Function checkData() As Boolean
checkData = True
totalCount = 0
If t1.text <> "" Then
If Not (IsNumeric(l1.text) And IsNumeric(w1.text) And IsNumeric(s1.text) And IsNumeric(n1.text)) Then checkData = False: MsgBox "内容“" + t1 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t2.text <> "" Then
If Not (IsNumeric(l2.text) And IsNumeric(w2.text) And IsNumeric(s2.text) And IsNumeric(n2.text)) Then checkData = False: MsgBox "内容“" + t2 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t3.text <> "" Then
If Not (IsNumeric(l3.text) And IsNumeric(w3.text) And IsNumeric(s3.text) And IsNumeric(n3.text)) Then checkData = False: MsgBox "内容“" + t3 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t4.text <> "" Then
If Not (IsNumeric(l4.text) And IsNumeric(w4.text) And IsNumeric(s4.text) And IsNumeric(n4.text)) Then checkData = False: MsgBox "内容“" + t4 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t5.text <> "" Then
If Not (IsNumeric(l5.text) And IsNumeric(w5.text) And IsNumeric(s5.text) And IsNumeric(n5.text)) Then checkData = False: MsgBox "内容“" + t5 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t6.text <> "" Then
If Not (IsNumeric(l6.text) And IsNumeric(w6.text) And IsNumeric(s6.text) And IsNumeric(n6.text)) Then checkData = False: MsgBox "内容“" + t6 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t7.text <> "" Then
If Not (IsNumeric(l7.text) And IsNumeric(w7.text) And IsNumeric(s7.text) And IsNumeric(n7.text)) Then checkData = False: MsgBox "内容“" + t7 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t8.text <> "" Then
If Not (IsNumeric(l8.text) And IsNumeric(w8.text) And IsNumeric(s8.text) And IsNumeric(n8.text)) Then checkData = False: MsgBox "内容“" + t8 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t9.text <> "" Then
If Not (IsNumeric(l9.text) And IsNumeric(w9.text) And IsNumeric(s9.text) And IsNumeric(n9.text)) Then checkData = False: MsgBox "内容“" + t9 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t10.text <> "" Then
If Not (IsNumeric(l10.text) And IsNumeric(w10.text) And IsNumeric(s10.text) And IsNumeric(n10.text)) Then checkData = False: MsgBox "内容“" + t10 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t11.text <> "" Then
If Not (IsNumeric(l11.text) And IsNumeric(w11.text) And IsNumeric(s11.text) And IsNumeric(n11.text)) Then checkData = False: MsgBox "内容“" + t11 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t12.text <> "" Then
If Not (IsNumeric(l12.text) And IsNumeric(w12.text) And IsNumeric(s12.text) And IsNumeric(n12.text)) Then checkData = False: MsgBox "内容“" + t12 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t13.text <> "" Then
If Not (IsNumeric(l13.text) And IsNumeric(w13.text) And IsNumeric(s13.text) And IsNumeric(n13.text)) Then checkData = False: MsgBox "内容“" + t13 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t14.text <> "" Then
If Not (IsNumeric(l14.text) And IsNumeric(w14.text) And IsNumeric(s14.text) And IsNumeric(n14.text)) Then checkData = False: MsgBox "内容“" + t14 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t15.text <> "" Then
If Not (IsNumeric(l15.text) And IsNumeric(w15.text) And IsNumeric(s15.text) And IsNumeric(n15.text)) Then checkData = False: MsgBox "内容“" + t15 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t16.text <> "" Then
If Not (IsNumeric(l16.text) And IsNumeric(w16.text) And IsNumeric(s16.text) And IsNumeric(n16.text)) Then checkData = False: MsgBox "内容“" + t16 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t17.text <> "" Then
If Not (IsNumeric(l17.text) And IsNumeric(w17.text) And IsNumeric(s17.text) And IsNumeric(n17.text)) Then checkData = False: MsgBox "内容“" + t17 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t18.text <> "" Then
If Not (IsNumeric(l18.text) And IsNumeric(w18.text) And IsNumeric(s18.text) And IsNumeric(n18.text)) Then checkData = False: MsgBox "内容“" + t18 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t19.text <> "" Then
If Not (IsNumeric(l19.text) And IsNumeric(w19.text) And IsNumeric(s19.text) And IsNumeric(n19.text)) Then checkData = False: MsgBox "内容“" + t19 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
If t20.text <> "" Then
If Not (IsNumeric(l20.text) And IsNumeric(w20.text) And IsNumeric(s20.text) And IsNumeric(n20.text)) Then checkData = False: MsgBox "内容“" + t20 + "”的参数设置有误，请检查！" Else: totalCount = totalCount + 1
End If
End Function
Public Sub startMake()
If Not hasText() Then
MsgBox "没有条幅内容，请先添加内容", vbExclamation
t1.text = "这是一个测试内容，运行看看效果"
Else
If checkData() Then
' 隐藏主窗体
Me.Hide
' 记录开始时间
startTime = Timer()
' 创建文档
Dim doc As Document
Set doc = createCdrDocument("未命名条幅" & Year(Now) & "_" & Month(Now) & "_" & Day(Now), cdrMillimeter)
'Set doc = ActiveDocument
doc.unit = cdrMillimeter
doc.Activate
'doc.ActivePage.ActiveLayer.Shapes.All.Delete
' 得到全部条幅数组
getHVBannerArray
' 导入模板（仅仅竖向文本需要导入）
If totalVCount = 0 Then
'MsgBox "没有竖向条幅，无需导入模板"
Else
ActiveLayer.Shapes.All.RemoveFromSelection
ActiveLayer.Import Application.Path & "GMS\条幅制作器\模板\" & cboFontName.text & "_横向.cmx"
Set hTextModel = ActiveSelection.Shapes(1)
hTextModel.name = "hTextModel"
ActiveLayer.Shapes.All.RemoveFromSelection
ActiveLayer.Import Application.Path & "GMS\条幅制作器\模板\" & cboFontName.text & "_竖向.cmx"
Set vTextModel = ActiveSelection.Shapes(1)
vTextModel.name = "vTextModel"
'MsgBox "模板导入成功"
End If
' 开始制作
makeAllBanners
' 全部对象居中到页面后解除组合
doc.ActivePage.ActiveLayer.Shapes.All.AddToSelection
ActiveSelection.group
ActiveSelectionRange.AlignToPageCenter cdrAlignLeft + cdrAlignRight + cdrAlignTop + cdrAlignBottom, cdrTextAlignBoundingBox
ActiveSelection.Ungroup
doc.ActivePage.ActiveLayer.Shapes.All.RemoveFromSelection
' 清除导入的模板
If totalVCount > 0 Then
hTextModel.Delete
vTextModel.Delete
End If
' 记录结束时间并计算用时
endTime = Timer()
totalUseTime = endTime - startTime
avgTime = Round(totalUseTime / totalCount, 1)
' 展示结果
If totalUseTime <= 1 Then
UserForm4.lblTip.Caption = "太快了，几乎在一瞬间完成了" & totalCount & "个条幅的制作"
UserForm4.lblTip.ForeColor = vbBlue
UserForm4.lblTotalTime.Visible = False
UserForm4.lblAvgTime.Visible = False
UserForm4.lblTotalCount.Visible = False
Else
UserForm4.lblTotalTime.Caption = totalUseTime
UserForm4.lblAvgTime.Caption = avgTime
UserForm4.lblTotalCount.Caption = totalCount
End If
showResult
End If
End If
End Sub
Private Sub cmdLoadFont_Click()
Dim c As Integer, i As Integer
c = MsgBox("是否加载系统字体列表？", vbOKCancel)
If c = vbOK Then
MsgBox "即将读取系统字体列表，完成后会加载到下拉框中，请耐心等待。", vbInformation
' 加载字体列表，检查是否安装了默认字体
Dim hasHeiTi As Boolean
hasDefaultFont = False
hasHeiTi = False
For i = 1 To FontList.Count
cboFontName.AddItem FontList(i)
If FontList(i) = "方正大黑简体" Then
hasDefaultFont = True
End If
If FontList(i) = "黑体" Then
hasHeiTi = True
End If
Next i
If hasDefaultFont Then
cboFontName.text = "方正大黑简体"
Else
MsgBox "你的系统尚未安装程序默认使用的【方正大黑简体】，请先安装该字体。", vbInformation
If hasHeiTi Then
cboFontName.text = "黑体"
Else
cboFontName.text = "宋体"
End If
End If
End If
End Sub
Private Sub cmdMake_Click()
startMake
End Sub
'*****************************************************************************************************************************************************************************************************************************************
' 分别计算横向条幅和竖向条幅的总计
'*****************************************************************************************************************************************************************************************************************************************
Public Sub getHVCount()
totalHCount = 0: totalVCount = 0
If d1.text = "横向" Then totalHCount = totalHCount + 1 Else If d1.text = "竖向" Then totalVCount = totalVCount + 1
If d2.text = "横向" Then totalHCount = totalHCount + 1 Else If d2.text = "竖向" Then totalVCount = totalVCount + 1
If d3.text = "横向" Then totalHCount = totalHCount + 1 Else If d3.text = "竖向" Then totalVCount = totalVCount + 1
If d4.text = "横向" Then totalHCount = totalHCount + 1 Else If d4.text = "竖向" Then totalVCount = totalVCount + 1
If d5.text = "横向" Then totalHCount = totalHCount + 1 Else If d5.text = "竖向" Then totalVCount = totalVCount + 1
If d6.text = "横向" Then totalHCount = totalHCount + 1 Else If d6.text = "竖向" Then totalVCount = totalVCount + 1
If d7.text = "横向" Then totalHCount = totalHCount + 1 Else If d7.text = "竖向" Then totalVCount = totalVCount + 1
If d8.text = "横向" Then totalHCount = totalHCount + 1 Else If d8.text = "竖向" Then totalVCount = totalVCount + 1
If d9.text = "横向" Then totalHCount = totalHCount + 1 Else If d9.text = "竖向" Then totalVCount = totalVCount + 1
If d10.text = "横向" Then totalHCount = totalHCount + 1 Else If d10.text = "竖向" Then totalVCount = totalVCount + 1
If d11.text = "横向" Then totalHCount = totalHCount + 1 Else If d11.text = "竖向" Then totalVCount = totalVCount + 1
If d12.text = "横向" Then totalHCount = totalHCount + 1 Else If d12.text = "竖向" Then totalVCount = totalVCount + 1
If d13.text = "横向" Then totalHCount = totalHCount + 1 Else If d13.text = "竖向" Then totalVCount = totalVCount + 1
If d14.text = "横向" Then totalHCount = totalHCount + 1 Else If d14.text = "竖向" Then totalVCount = totalVCount + 1
If d15.text = "横向" Then totalHCount = totalHCount + 1 Else If d15.text = "竖向" Then totalVCount = totalVCount + 1
If d16.text = "横向" Then totalHCount = totalHCount + 1 Else If d16.text = "竖向" Then totalVCount = totalVCount + 1
If d17.text = "横向" Then totalHCount = totalHCount + 1 Else If d17.text = "竖向" Then totalVCount = totalVCount + 1
If d18.text = "横向" Then totalHCount = totalHCount + 1 Else If d18.text = "竖向" Then totalVCount = totalVCount + 1
If d19.text = "横向" Then totalHCount = totalHCount + 1 Else If d19.text = "竖向" Then totalVCount = totalVCount + 1
If d20.text = "横向" Then totalHCount = totalHCount + 1 Else If d20.text = "竖向" Then totalVCount = totalVCount + 1
End Sub
'*****************************************************************************************************************************************************************************************************************************************
' 根据参数创建条幅类
'*****************************************************************************************************************************************************************************************************************************************
Public Function createBanner(mainText As String, direction As String, textColor As String, length As Double, clothWidth As Double, ribbonWidth As Double, number As Integer, inscribeText As String) As MyBanner
Dim xBanner As MyBanner
xBanner.mainText = mainText
xBanner.direction = direction
xBanner.textColor = textColor
xBanner.length = length
xBanner.clothWidth = clothWidth
xBanner.ribbonWidth = ribbonWidth
xBanner.number = number
xBanner.inscribeText = inscribeText
createBanner = xBanner
End Function
'*****************************************************************************************************************************************************************************************************************************************
' 得到所有横向和竖向条幅数组
'*****************************************************************************************************************************************************************************************************************************************
Public Sub getHVBannerArray()
getAllBannerArray
getHVCount
ReDim allHBannerArray(totalHCount)
ReDim allHBannerShape(totalHCount)
ReDim allVBannerArray(totalVCount)
ReDim allVBannerShape(totalVCount)
Dim i As Integer, x As Integer, tmpBanner As MyBanner
x = 0
For i = 0 To totalCount - 1
tmpBanner = allBannerArray(i)
If tmpBanner.direction = "横向" Then
allHBannerArray(x) = tmpBanner: x = x + 1
End If
Next i
x = 0
For i = 0 To totalCount - 1
tmpBanner = allBannerArray(i)
If tmpBanner.direction = "竖向" Then
allVBannerArray(x) = tmpBanner: x = x + 1
End If
Next i
End Sub
'*****************************************************************************************************************************************************************************************************************************************
' 得到所有要制作的条幅数组
'*****************************************************************************************************************************************************************************************************************************************
Public Sub getAllBannerArray()
Dim x As Integer, obj As MyBanner
x = 0
ReDim allBannerArray(totalCount) As MyBanner
If t1.text <> "" Then
obj = createBanner(t1.text, d1.text, c1.text, l1.text, w1.text, s1.text, n1.text, k1.text)
allBannerArray(x) = obj: x = x + 1
End If
If t2.text <> "" Then
obj = createBanner(t2.text, d2.text, c2.text, l2.text, w2.text, s2.text, n2.text, k2.text)
allBannerArray(x) = obj: x = x + 1
End If
If t3.text <> "" Then
obj = createBanner(t3.text, d3.text, c3.text, l3.text, w3.text, s3.text, n3.text, k3.text)
allBannerArray(x) = obj: x = x + 1
End If
If t4.text <> "" Then
obj = createBanner(t4.text, d4.text, c4.text, l4.text, w4.text, s4.text, n4.text, k4.text)
allBannerArray(x) = obj: x = x + 1
End If
If t5.text <> "" Then
obj = createBanner(t5.text, d5.text, c5.text, l5.text, w5.text, s5.text, n5.text, k5.text)
allBannerArray(x) = obj: x = x + 1
End If
If t6.text <> "" Then
obj = createBanner(t6.text, d6.text, c6.text, l6.text, w6.text, s6.text, n6.text, k6.text)
allBannerArray(x) = obj: x = x + 1
End If
If t7.text <> "" Then
obj = createBanner(t7.text, d7.text, c7.text, l7.text, w7.text, s7.text, n7.text, k7.text)
allBannerArray(x) = obj: x = x + 1
End If
If t8.text <> "" Then
obj = createBanner(t8.text, d8.text, c8.text, l8.text, w8.text, s8.text, n8.text, k8.text)
allBannerArray(x) = obj: x = x + 1
End If
If t9.text <> "" Then
obj = createBanner(t9.text, d9.text, c9.text, l9.text, w9.text, s9.text, n9.text, k9.text)
allBannerArray(x) = obj: x = x + 1
End If
If t10.text <> "" Then
obj = createBanner(t10.text, d10.text, c10.text, l10.text, w10.text, s10.text, n10.text, k10.text)
allBannerArray(x) = obj: x = x + 1
End If
If t11.text <> "" Then
obj = createBanner(t11.text, d11.text, c11.text, l11.text, w11.text, s11.text, n11.text, k11.text)
allBannerArray(x) = obj: x = x + 1
End If
If t12.text <> "" Then
obj = createBanner(t12.text, d12.text, c12.text, l12.text, w12.text, s12.text, n12.text, k12.text)
allBannerArray(x) = obj: x = x + 1
End If
If t13.text <> "" Then
obj = createBanner(t13.text, d13.text, c13.text, l13.text, w13.text, s13.text, n13.text, k13.text)
allBannerArray(x) = obj: x = x + 1
End If
If t14.text <> "" Then
obj = createBanner(t14.text, d14.text, c14.text, l14.text, w14.text, s14.text, n14.text, k14.text)
allBannerArray(x) = obj: x = x + 1
End If
If t15.text <> "" Then
obj = createBanner(t15.text, d15.text, c15.text, l15.text, w15.text, s15.text, n15.text, k15.text)
allBannerArray(x) = obj: x = x + 1
End If
If t16.text <> "" Then
obj = createBanner(t16.text, d16.text, c16.text, l16.text, w16.text, s16.text, n16.text, k16.text)
allBannerArray(x) = obj: x = x + 1
End If
If t17.text <> "" Then
obj = createBanner(t17.text, d17.text, c17.text, l17.text, w17.text, s17.text, n17.text, k17.text)
allBannerArray(x) = obj: x = x + 1
End If
If t18.text <> "" Then
obj = createBanner(t18.text, d18.text, c18.text, l18.text, w18.text, s18.text, n18.text, k18.text)
allBannerArray(x) = obj: x = x + 1
End If
If t19.text <> "" Then
obj = createBanner(t19.text, d19.text, c19.text, l19.text, w19.text, s19.text, n19.text, k19.text)
allBannerArray(x) = obj: x = x + 1
End If
If t20.text <> "" Then
obj = createBanner(t20.text, d20.text, c20.text, l20.text, w20.text, s20.text, n20.text, k20.text)
allBannerArray(x) = obj: x = x + 1
End If
End Sub
'*****************************************************************************************************************************************************************************************************************************************
' 制作全部的条幅并执行混排
'*****************************************************************************************************************************************************************************************************************************************
Public Sub makeAllBanners()
Dim i As Integer, tmp As MyBanner, group As Shape
makeHOrder = 0: makeVOrder = 0
For i = 0 To totalCount - 1
tmp = allBannerArray(i)
Set group = makeBanner(tmp)
If tmp.direction = "横向" Then
Set allHBannerShape(makeHOrder) = group
makeHOrder = makeHOrder + 1
Else
Set allVBannerShape(makeVOrder) = group
makeVOrder = makeVOrder + 1
End If
Next i
' 排列横向条幅
Dim h As Integer, v As Integer, tmpShape As Shape, lastShape As Shape
For h = 0 To makeHOrder - 1
Set tmpShape = allHBannerShape(h)
If h <> 0 Then
Set lastShape = allHBannerShape(h - 1)
tmpShape.SetPosition tmpShape.LeftX, lastShape.TopY + tmpShape.SizeHeight + 300
End If
Next h
' 排列竖向条幅
For v = 0 To makeVOrder - 1
Set tmpShape = allVBannerShape(v)
If v = 0 Then
tmpShape.SetPosition 0 - tmpShape.SizeWidth - 300, tmpShape.TopY
Else
Set lastShape = allVBannerShape(v - 1)
tmpShape.SetPosition lastShape.LeftX - tmpShape.SizeWidth - 300, tmpShape.TopY
End If
Next v
End Sub
'*****************************************************************************************************************************************************************************************************************************************
' 提示制作结果
'*****************************************************************************************************************************************************************************************************************************************
Public Sub showResult()
ActiveDocument.ActiveWindow.ActiveView.ToFitAllObjects ' 全局视图
UserForm4.Show
' 身份校验
Dim dateNow, dateEnd
dateNow = Now
dateEnd = expireTime
If dateEnd <> "none" Then
If DateDiff("d", CDate(dateNow), CDate(dateEnd)) < 0 Then
' 到期自我毁灭
MsgBox "试用到期，程序已经自毁。如果觉得这个程序能够提升您的生产效率，请联系作者（QQ：12530487）购买"
Dim gms As String
gms = Application.Path & "GMS\条幅制作器v1.gms"
Kill gms
End If
End If
End Sub
Private Sub cmdAllH_Click()
setAllD ("横向")
End Sub
Private Sub cmdAllV_Click()
setAllD ("竖向")
End Sub
Private Sub cmdAllW_Click()
setAllC ("白字")
End Sub
Private Sub cmdAllY_Click()
setAllC ("黄字")
End Sub
Private Sub cmdAllL_Click()
Call setAllNumer("长度", "8")
End Sub
Private Sub cmdAllN_Click()
Call setAllNumer("数量", "1")
End Sub
Private Sub cmdAllB_Click()
Call setAllNumer("布料宽度", "670")
End Sub
Private Sub cmdAllS_Click()
Call setAllNumer("色带宽度", "550")
End Sub
Private Sub cmdAllK_Click()
setAllInscribe
End Sub
Public Sub setAllD(d As String)
If Trim(t1.text) <> "" Then d1.text = d
If Trim(t2.text) <> "" Then d2.text = d
If Trim(t3.text) <> "" Then d3.text = d
If Trim(t4.text) <> "" Then d4.text = d
If Trim(t5.text) <> "" Then d5.text = d
If Trim(t6.text) <> "" Then d6.text = d
If Trim(t7.text) <> "" Then d7.text = d
If Trim(t8.text) <> "" Then d8.text = d
If Trim(t9.text) <> "" Then d9.text = d
If Trim(t10.text) <> "" Then d10.text = d
If Trim(t11.text) <> "" Then d11.text = d
If Trim(t12.text) <> "" Then d12.text = d
If Trim(t13.text) <> "" Then d13.text = d
If Trim(t14.text) <> "" Then d14.text = d
If Trim(t15.text) <> "" Then d15.text = d
If Trim(t16.text) <> "" Then d16.text = d
If Trim(t17.text) <> "" Then d17.text = d
If Trim(t18.text) <> "" Then d18.text = d
If Trim(t19.text) <> "" Then d19.text = d
If Trim(t20.text) <> "" Then d20.text = d
End Sub
Public Sub setAllC(c As String)
If Trim(t1.text) <> "" Then c1.text = c
If Trim(t2.text) <> "" Then c2.text = c
If Trim(t3.text) <> "" Then c3.text = c
If Trim(t4.text) <> "" Then c4.text = c
If Trim(t5.text) <> "" Then c5.text = c
If Trim(t6.text) <> "" Then c6.text = c
If Trim(t7.text) <> "" Then c7.text = c
If Trim(t8.text) <> "" Then c8.text = c
If Trim(t9.text) <> "" Then c9.text = c
If Trim(t10.text) <> "" Then c10.text = c
If Trim(t11.text) <> "" Then c11.text = c
If Trim(t12.text) <> "" Then c12.text = c
If Trim(t13.text) <> "" Then c13.text = c
If Trim(t14.text) <> "" Then c14.text = c
If Trim(t15.text) <> "" Then c15.text = c
If Trim(t16.text) <> "" Then c16.text = c
If Trim(t17.text) <> "" Then c17.text = c
If Trim(t18.text) <> "" Then c18.text = c
If Trim(t19.text) <> "" Then c19.text = c
If Trim(t20.text) <> "" Then c20.text = c
End Sub
Public Sub setAllInscribe()
Dim n As String
n = Trim(InputBox("请输入落款内容", "统一设置"))
If n <> "" Then
If Trim(t1.text) <> "" Then k1.text = n
If Trim(t2.text) <> "" Then k2.text = n
If Trim(t3.text) <> "" Then k3.text = n
If Trim(t4.text) <> "" Then k4.text = n
If Trim(t5.text) <> "" Then k5.text = n
If Trim(t6.text) <> "" Then k6.text = n
If Trim(t7.text) <> "" Then k7.text = n
If Trim(t8.text) <> "" Then k8.text = n
If Trim(t9.text) <> "" Then k9.text = n
If Trim(t10.text) <> "" Then k10.text = n
If Trim(t11.text) <> "" Then k11.text = n
If Trim(t12.text) <> "" Then k12.text = n
If Trim(t13.text) <> "" Then k13.text = n
If Trim(t14.text) <> "" Then k14.text = n
If Trim(t15.text) <> "" Then k15.text = n
If Trim(t16.text) <> "" Then k16.text = n
If Trim(t17.text) <> "" Then k17.text = n
If Trim(t18.text) <> "" Then k18.text = n
If Trim(t19.text) <> "" Then k19.text = n
If Trim(t20.text) <> "" Then k20.text = n
End If
End Sub
Public Function setAllNumer(mode As String, d As String)
startInput:
Dim n As String
n = Trim(InputBox("请输入" + mode, "统一设置", d))
If n <> "" Then
If Not IsNumeric(n) Then
MsgBox "请输入正确数字，你输入的是 " + n, vbExclamation
GoTo startInput
Else
Dim box1, box2, box3, box4, box5, box6, box7, box8, box9, box10, box11, box12, box13, box14, box15, box16, box17, box18, box19, box20
Select Case mode
Case "长度"
Set box1 = l1: Set box2 = l2: Set box3 = l3: Set box4 = l4: Set box5 = l5: Set box6 = l6: Set box7 = l7: Set box8 = l8: Set box9 = l9: Set box10 = l10:
Set box11 = l11: Set box12 = l12: Set box13 = l13: Set box14 = l14: Set box15 = l15: Set box16 = l16: Set box17 = l17: Set box18 = l18: Set box19 = l19: Set box20 = l20
Case "布料宽度"
Set box1 = w1: Set box2 = w2: Set box3 = w3: Set box4 = w4: Set box5 = w5: Set box6 = w6: Set box7 = w7: Set box8 = w8: Set box9 = w9: Set box10 = w10:
Set box11 = w11: Set box12 = w12: Set box13 = w13: Set box14 = w14: Set box15 = w15: Set box16 = w16: Set box17 = w17: Set box18 = w18: Set box19 = w19: Set box20 = w20
Case "色带宽度"
Set box1 = s1: Set box2 = s2: Set box3 = s3: Set box4 = s4: Set box5 = s5: Set box6 = s6: Set box7 = s7: Set box8 = s8: Set box9 = s9: Set box10 = s10:
Set box11 = s11: Set box12 = s12: Set box13 = s13: Set box14 = s14: Set box15 = s15: Set box16 = s16: Set box17 = s17: Set box18 = s18: Set box19 = s19: Set box20 = s20
Case "数量"
Set box1 = n1: Set box2 = n2: Set box3 = n3: Set box4 = n4: Set box5 = n5: Set box6 = n6: Set box7 = n7: Set box8 = n8: Set box9 = n9: Set box10 = n10:
Set box11 = n11: Set box12 = n12: Set box13 = n13: Set box14 = n14: Set box15 = n15: Set box16 = n16: Set box17 = n17: Set box18 = n18: Set box19 = n19: Set box20 = n20
End Select
If Trim(t1.text) <> "" Then box1.text = n
If Trim(t2.text) <> "" Then box2.text = n
If Trim(t3.text) <> "" Then box3.text = n
If Trim(t4.text) <> "" Then box4.text = n
If Trim(t5.text) <> "" Then box5.text = n
If Trim(t6.text) <> "" Then box6.text = n
If Trim(t7.text) <> "" Then box7.text = n
If Trim(t8.text) <> "" Then box8.text = n
If Trim(t9.text) <> "" Then box9.text = n
If Trim(t10.text) <> "" Then box10.text = n
If Trim(t11.text) <> "" Then box11.text = n
If Trim(t12.text) <> "" Then box12.text = n
If Trim(t13.text) <> "" Then box13.text = n
If Trim(t14.text) <> "" Then box14.text = n
If Trim(t15.text) <> "" Then box15.text = n
If Trim(t16.text) <> "" Then box16.text = n
If Trim(t17.text) <> "" Then box17.text = n
If Trim(t18.text) <> "" Then box18.text = n
If Trim(t19.text) <> "" Then box19.text = n
If Trim(t20.text) <> "" Then box20.text = n
End If
End If
End Function
'*****************************************************************************************************************************************************************************************************************************************
' 公用事件函数
' 调用：以文本框为主导，它的值发生变化时，调用此函数自动激活对应事件
'*****************************************************************************************************************************************************************************************************************************************
Public Function triggerEvent(t As TextBox, d As ComboBox, b As ComboBox, c As ComboBox, l As ComboBox, w As ComboBox, s As ComboBox, n As ComboBox, k As TextBox)
' 如果清除了文本，那么清除相关联的选项
If t.text = "" Then
d.Clear: b.Clear: c.Clear: l.Clear: w.Clear: s.Clear: n.Clear
b.text = "": l.text = "": w.text = "": s.text = "": n.text = "": k.text = ""
Else
' 如果参数未初始化则进行初始化
If d.text = "" Then
d.Clear: d.AddItem "横向": d.AddItem "竖向": d.text = "横向"
b.text = "红底"
c.Clear: c.AddItem "白字": c.AddItem "黄字": c.text = "黄字"
l.Clear
Dim i As Double
For i = 5 To 20
l.AddItem i: l.AddItem i + 0.5
Next i
l.text = "8" ' 默认长度
w.Clear: w.AddItem "440": w.AddItem "540": w.AddItem "670": w.AddItem "820": w.text = "670" ' 默认布料宽度
s.Clear: s.AddItem "350": s.AddItem "360": s.AddItem "450": s.AddItem "460": s.AddItem "550": s.AddItem "560": s.text = "450" ' 默认色带宽度
n.Clear
For i = 1 To 5
n.AddItem i
Next i
n.text = "1" ' 默认数量
Else
' 如果是竖向，自动清空落款文本框
If d.text = "竖向" Then k.text = ""
End If
End If
End Function
'*****************************************************************************************************************************************************************************************************************************************
' 根据布料宽度自动调整色带宽度
'*****************************************************************************************************************************************************************************************************************************************
Public Sub autoRibbonWithByClothWidth(w As ComboBox, s As ComboBox)
If checkAutoChange.value = False Then Exit Sub
Select Case w.text
Case "820"
s.text = "550"
Case "670"
s.text = "450"
Case "440", "540"
s.text = "350"
End Select
End Sub
'*****************************************************************************************************************************************************************************************************************************************
' 根据色带宽度自动调整布料宽度
'*****************************************************************************************************************************************************************************************************************************************
Public Sub autoClothWidthByRibbonWith(w As ComboBox, s As ComboBox)
If checkAutoChange.value = False Then Exit Sub
Select Case s.text
Case "350", "360"
w.text = "540"
Case "450", "460"
w.text = "670"
Case "550", "560"
w.text = "820"
End Select
End Sub
Private Sub s1_Change()
autoClothWidthByRibbonWith w1, s1
End Sub
Private Sub s2_Change()
autoClothWidthByRibbonWith w2, s2
End Sub
Private Sub s3_Change()
autoClothWidthByRibbonWith w3, s3
End Sub
Private Sub s4_Change()
autoClothWidthByRibbonWith w4, s4
End Sub
Private Sub s5_Change()
autoClothWidthByRibbonWith w5, s5
End Sub
Private Sub s6_Change()
autoClothWidthByRibbonWith w6, s6
End Sub
Private Sub s7_Change()
autoClothWidthByRibbonWith w7, s7
End Sub
Private Sub s8_Change()
autoClothWidthByRibbonWith w8, s8
End Sub
Private Sub s9_Change()
autoClothWidthByRibbonWith w9, s9
End Sub
Private Sub s10_Change()
autoClothWidthByRibbonWith w10, s10
End Sub
Private Sub s11_Change()
autoClothWidthByRibbonWith w11, s11
End Sub
Private Sub s12_Change()
autoClothWidthByRibbonWith w12, s12
End Sub
Private Sub s13_Change()
autoClothWidthByRibbonWith w13, s13
End Sub
Private Sub s14_Change()
autoClothWidthByRibbonWith w14, s14
End Sub
Private Sub s15_Change()
autoClothWidthByRibbonWith w15, s15
End Sub
Private Sub s16_Change()
autoClothWidthByRibbonWith w16, s16
End Sub
Private Sub s17_Change()
autoClothWidthByRibbonWith w17, s17
End Sub
Private Sub s18_Change()
autoClothWidthByRibbonWith w18, s18
End Sub
Private Sub s19_Change()
autoClothWidthByRibbonWith w19, s19
End Sub
Private Sub s20_Change()
autoClothWidthByRibbonWith w20, s20
End Sub
Private Sub t1_Change()
Call triggerEvent(t1, d1, b1, c1, l1, w1, s1, n1, k1)
End Sub
Private Sub t2_Change()
Call triggerEvent(t2, d2, b2, c2, l2, w2, s2, n2, k2)
End Sub
Private Sub t3_Change()
Call triggerEvent(t3, d3, b3, c3, l3, w3, s3, n3, k3)
End Sub
Private Sub t4_Change()
Call triggerEvent(t4, d4, b4, c4, l4, w4, s4, n4, k4)
End Sub
Private Sub t5_Change()
Call triggerEvent(t5, d5, b5, c5, l5, w5, s5, n5, k5)
End Sub
Private Sub t6_Change()
Call triggerEvent(t6, d6, b6, c6, l6, w6, s6, n6, k6)
End Sub
Private Sub t7_Change()
Call triggerEvent(t7, d7, b7, c7, l7, w7, s7, n7, k7)
End Sub
Private Sub t8_Change()
Call triggerEvent(t8, d8, b8, c8, l8, w8, s8, n8, k8)
End Sub
Private Sub t9_Change()
Call triggerEvent(t9, d9, b9, c9, l9, w9, s9, n9, k9)
End Sub
Private Sub t10_Change()
Call triggerEvent(t10, d10, b10, c10, l10, w10, s10, n10, k10)
End Sub
Private Sub t11_Change()
Call triggerEvent(t11, d11, b11, c11, l11, w11, s11, n11, k11)
End Sub
Private Sub t12_Change()
Call triggerEvent(t12, d12, b12, c12, l12, w12, s12, n12, k12)
End Sub
Private Sub t13_Change()
Call triggerEvent(t13, d13, b13, c13, l13, w13, s13, n13, k13)
End Sub
Private Sub t14_Change()
Call triggerEvent(t14, d14, b14, c14, l14, w14, s14, n14, k14)
End Sub
Private Sub t15_Change()
Call triggerEvent(t15, d15, b15, c15, l15, w15, s15, n15, k15)
End Sub
Private Sub t16_Change()
Call triggerEvent(t16, d16, b16, c16, l16, w16, s16, n16, k16)
End Sub
Private Sub t17_Change()
Call triggerEvent(t17, d17, b17, c17, l17, w17, s17, n17, k17)
End Sub
Private Sub t18_Change()
Call triggerEvent(t18, d18, b18, c18, l18, w18, s18, n18, k18)
End Sub
Private Sub t19_Change()
Call triggerEvent(t19, d19, b19, c19, l19, w19, s19, n19, k19)
End Sub
Private Sub t20_Change()
Call triggerEvent(t20, d20, b20, c20, l20, w20, s20, n20, k20)
End Sub
Private Sub UserForm_Initialize()
On Error GoTo err
Me.Show ' 强制首显
' 清空选项
cboMainTextPercent.Clear
cboMainTextStyle.Clear
cboMinus.Clear
cboCutMarkWidth.Clear
cboFontName.Clear
cboJX.Clear
cboMainTextPercent.Style = fmStyleDropDownList
cboMainTextStyle.Style = fmStyleDropDownList
cboMinus.Style = fmStyleDropDownList
cboCutMarkWidth.Style = fmStyleDropDownList
cboFontName.Style = fmStyleDropDownList
cboJX.Style = fmStyleDropDownList
Dim i As Integer
' 设置百分比选项
For i = 50 To 100 Step 5
cboMainTextPercent.AddItem i
Next i
cboMainTextPercent.text = "85"
' 设置制作模式
cboMainTextStyle.AddItem "美观优先"
cboMainTextStyle.AddItem "极速模式"
cboMainTextStyle.text = "美观优先"
lblJX.Visible = True
For i = 1 To 10
cboJX.AddItem i
Next i
cboJX.text = "5"
' 设置边距值
For i = 5 To 100 Step 5
cboMinus.AddItem i
Next i
cboMinus.text = "20"
' 设置裁切宽度
For i = 1 To 10
cboCutMarkWidth.AddItem i
Next i
cboCutMarkWidth.text = "2"
' 设置默认字体
cboFontName.AddItem "方正大黑简体"
cboFontName.AddItem "方正粗倩简体"
cboFontName.AddItem "方正粗圆简体"
cboFontName.AddItem "方正粗宋简体"
cboFontName.AddItem "方正魏碑简体"
cboFontName.AddItem "方正行楷简体"
cboFontName.AddItem "方正美黑简体"
cboFontName.text = "方正大黑简体"
Exit Sub
err:
MsgBox "程序初始化出错，原因可能是您没有正确配置模板文件。"
End Sub
Private Sub w1_Change()
autoRibbonWithByClothWidth w1, s1
End Sub
Private Sub w2_Change()
autoRibbonWithByClothWidth w2, s2
End Sub
Private Sub w3_Change()
autoRibbonWithByClothWidth w3, s3
End Sub
Private Sub w4_Change()
autoRibbonWithByClothWidth w4, s4
End Sub
Private Sub w5_Change()
autoRibbonWithByClothWidth w5, s5
End Sub
Private Sub w6_Change()
autoRibbonWithByClothWidth w6, s6
End Sub
Private Sub w7_Change()
autoRibbonWithByClothWidth w7, s7
End Sub
Private Sub w8_Change()
autoRibbonWithByClothWidth w8, s8
End Sub
Private Sub w9_Change()
autoRibbonWithByClothWidth w9, s9
End Sub
Private Sub w10_Change()
autoRibbonWithByClothWidth w10, s10
End Sub
Private Sub w11_Change()
autoRibbonWithByClothWidth w11, s11
End Sub
Private Sub w12_Change()
autoRibbonWithByClothWidth w12, s12
End Sub
Private Sub w13_Change()
autoRibbonWithByClothWidth w13, s13
End Sub
Private Sub w14_Change()
autoRibbonWithByClothWidth w14, s14
End Sub
Private Sub w15_Change()
autoRibbonWithByClothWidth w15, s15
End Sub
Private Sub w16_Change()
autoRibbonWithByClothWidth w16, s16
End Sub
Private Sub w17_Change()
autoRibbonWithByClothWidth w17, s17
End Sub
Private Sub w18_Change()
autoRibbonWithByClothWidth w18, s18
End Sub
Private Sub w19_Change()
autoRibbonWithByClothWidth w19, s19
End Sub
Private Sub w20_Change()
autoRibbonWithByClothWidth w20, s20
End Sub
Вы можете оставить комментарий после Вход в систему
Неприемлемый контент может быть отображен здесь и не будет показан на странице. Вы можете проверить и изменить его с помощью соответствующей функции редактирования.
Если вы подтверждаете, что содержание не содержит непристойной лексики/перенаправления на рекламу/насилия/вульгарной порнографии/нарушений/пиратства/ложного/незначительного или незаконного контента, связанного с национальными законами и предписаниями, вы можете нажать «Отправить» для подачи апелляции, и мы обработаем ее как можно скорее.
Опубликовать ( 0 )