[已解决]帮忙看看这段代码如何修改

opelwang

1. Sub 设置()
   
2.     Dim MN As Object
   
3.     On Error Resume Next
   
4.     Application.ScreenUpdating = False
   
5.     PS = ""
   
6.     Set MN = ActiveSheet.Shapes("QZ")
   
7.     If Not MN Is Nothing Then
   
8.         pass.Show
   
9.         If PS <> "1268" Then Exit Sub     '密碼
   
10.     End If
    
11.     UJM
    
12.     ActiveSheet.Shapes("QZ").Delete
    
13.     Set G = ActiveSheet.GroupBoxes.Add(20, 10, 582, 40)
    
14.     G.Characters.Text = "签  字  栏"
    
15.     G.Name = "G1"
    
16.     ActiveSheet.Shapes.AddShape(msoShapeRectangle, 19.8, 9.8, 581.5, 39.5).Select
    
17.     Selection.ShapeRange.ZOrder msoSendToBack
    
18.     Selection.ShapeRange.Fill.ForeColor.SchemeColor = 29
    
19.     Selection.ShapeRange.Fill.Solid
    
20.     Selection.ShapeRange.Line.Visible = msoFalse
    
21.     Selection.Name = "G2"
    
22.     ARR = Array("制表", "审核", "批准")   '標籤名
    
23.     For I = 1 To 3
    
24.         Set G = ActiveSheet.OLEObjects.Add(ClassType:="Forms.TextBox.1", Left:=70 + 188 * (I - 1), Top:=22, Width:=48, Height:=20)
    
25.         G.Name = "B" & I * 2 - 1
    
26.         G.Object.BackColor = &HE0E0E0      ' 框中顯示名稱底色
    
27.         G.Enabled = False
    
28.         Set G = ActiveSheet.OLEObjects.Add(ClassType:="Forms.TextBox.1", Left:=115 + 188 * (I - 1), Top:=22, Width:=65, Height:=20)
    
29.         G.Name = "B" & I * 2
    
30.         G.Object.BackColor = &HE0E0E0       ' 框中顯示日期底色
    
31.         G.Enabled = False
    
32.         Set G = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Label.1", Left:=30 + 188 * (I - 1), Top:=25, Width:=38, Height:=16)
    
33.         G.Name = "L" & I
    
34.         G.Object.Caption = ARR(I - 1)
    
35.         With G.Object.Font
    
36.             .Name = "標楷體"
    
37.             .Size = 14
    
38.             .ColorIndex = 5
    
39.             '.Bold = True
    
40.         End With
    
41.         G.Object.ForeColor = &H400000                '標識名字體顏色
    
42.         G.Object.BackColor = &H8080FF                '標籤名背景底色
    
43.     Next
    
44.     ZH
    
45.     ActiveSheet.Range("D3").Select
    
46.     Selection = 0
    
47.     Application.ScreenUpdating = True
    
48. End Sub

复制代码

1. 此用贴地址（44楼）：http://www.excelpx.com/thread-183575-5-1.html
   

复制代码

敬请各路英雄，帮我看看，以上图片中的问题，如何修正，谢谢～～
‘

最佳答案

月排行榜 / 总排行榜

zjdh

2011-8-14 14:12

增加一个变量WID,你只要改变WID的值即可：
Sub 设置()
    Dim MN As Object
    On Error Resume Next
    Application.ScreenUpdating = False
    PS = ""
    Set MN = ActiveSheet.Shapes("QZ")
    If Not MN Is Nothing Then
        密码验证.Show
        If PS <> "12345" Then Exit Sub     '密码
    End If
    UJM
    ActiveSheet.Shapes("QZ").Delete
    WID = 220
    Set G = ActiveSheet.GroupBoxes.Add(20, 10, WID * 2 + 205, 40)
    G.Characters.Text = "签 字 栏"
    G.Name = "G1"
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 19.8, 9.8, WID * 2 + 204.5, 39.5).Select
    Selection.ShapeRange.ZOrder msoSendToBack
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 41
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.Name = "G2"
    ARR = Array("制表：", "审核：", "批准：")   '标签名
    For I = 1 To 3
        Set G = ActiveSheet.OLEObjects.Add(ClassType:="Forms.TextBox.1", Left:=70 + WID * (I - 1), Top:=23, Width:=70, Height:=20)
        G.Name = "B" & I * 2 - 1
        G.Object.BackColor = &HC000&
        G.Enabled = False
        Set G = ActiveSheet.OLEObjects.Add(ClassType:="Forms.TextBox.1", Left:=142 + WID * (I - 1), Top:=23, Width:=70, Height:=20)
        G.Name = "B" & I * 2
        G.Object.BackColor = &HC000&
        G.Enabled = False
        Set G = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Label.1", Left:=32 + WID * (I - 1), Top:=28, Width:=38, Height:=21)
        G.Name = "L" & I
        G.Object.Caption = ARR(I - 1)
        With G.Object.Font
            .Name = "隶书"
            .Size = 12
        End With
        G.Object.ForeColor = &HFF0000
        G.Object.BackColor = &HFFFFC0
    Next
    ZH
    ActiveSheet.Range("D3").Select
    Selection = 0
    Application.ScreenUpdating = True
End Sub

跳转到最佳答案楼层

fjmxwrs

你应该把原文件发上来

opelwang

fjmxwrs 发表于 2011-8-14 11:27
你应该把原文件发上来

其实连接中有附件，还是听从版主的意见，把源文件发上来吧。

               附件： 另类签名权限.rar (81.23 KB, 下载次数: 5)

2011-8-14 12:05 上传

点击文件名下载附件

jiminyanyan

多思考，多动手，不要一有问题就提问，把那些看到过的代码加以消化，化为己用，才是王道。

zjdh

修改红色的数字：
Sub 设置()
    Dim MN As Object
    On Error Resume Next
    Application.ScreenUpdating = False
    PS = ""
    Set MN = ActiveSheet.Shapes("QZ")
    If Not MN Is Nothing Then
        密码验证.Show
        If PS <> "12345" Then Exit Sub     '密码
    End If
    UJM
    ActiveSheet.Shapes("QZ").Delete
    Set G = ActiveSheet.GroupBoxes.Add(20, 10, 645, 40)
    G.Characters.Text = "签 字 栏"
    G.Name = "G1"
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 19.8, 9.8, 644.5, 39.5).Select
    Selection.ShapeRange.ZOrder msoSendToBack
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 41
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.Name = "G2"
    ARR = Array("制表：", "审核：", "批准：")   '标签名
    For I = 1 To 3
        Set G = ActiveSheet.OLEObjects.Add(ClassType:="Forms.TextBox.1", Left:=70 + 220 * (I - 1), Top:=23, Width:=70, Height:=20)
        G.Name = "B" & I * 2 - 1
        G.Object.BackColor = &HC000&
        G.Enabled = False
        Set G = ActiveSheet.OLEObjects.Add(ClassType:="Forms.TextBox.1", Left:=142 + 220 * (I - 1), Top:=23, Width:=70, Height:=20)
        G.Name = "B" & I * 2
        G.Object.BackColor = &HC000&
        G.Enabled = False
        Set G = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Label.1", Left:=32 + 220 * (I - 1), Top:=28, Width:=38, Height:=21)
        G.Name = "L" & I
        G.Object.Caption = ARR(I - 1)
        With G.Object.Font
            .Name = "隶书"
            .Size = 12
        End With
        G.Object.ForeColor = &HFF0000
        G.Object.BackColor = &HFFFFC0
    Next
    ZH
    ActiveSheet.Range("D3").Select
    Selection = 0
    Application.ScreenUpdating = True
End Sub

zjdh

那个白边问题，手工操作没出现，录制宏运行就出现，不知何原因。
我上次回帖时就想了很多办法，没能解决。

zjdh

增加一个变量WID,你只要改变WID的值即可：
Sub 设置()
    Dim MN As Object
    On Error Resume Next
    Application.ScreenUpdating = False
    PS = ""
    Set MN = ActiveSheet.Shapes("QZ")
    If Not MN Is Nothing Then
        密码验证.Show
        If PS <> "12345" Then Exit Sub     '密码
    End If
    UJM
    ActiveSheet.Shapes("QZ").Delete
    WID = 220
    Set G = ActiveSheet.GroupBoxes.Add(20, 10, WID * 2 + 205, 40)
    G.Characters.Text = "签 字 栏"
    G.Name = "G1"
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 19.8, 9.8, WID * 2 + 204.5, 39.5).Select
    Selection.ShapeRange.ZOrder msoSendToBack
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 41
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.Name = "G2"
    ARR = Array("制表：", "审核：", "批准：")   '标签名
    For I = 1 To 3
        Set G = ActiveSheet.OLEObjects.Add(ClassType:="Forms.TextBox.1", Left:=70 + WID * (I - 1), Top:=23, Width:=70, Height:=20)
        G.Name = "B" & I * 2 - 1
        G.Object.BackColor = &HC000&
        G.Enabled = False
        Set G = ActiveSheet.OLEObjects.Add(ClassType:="Forms.TextBox.1", Left:=142 + WID * (I - 1), Top:=23, Width:=70, Height:=20)
        G.Name = "B" & I * 2
        G.Object.BackColor = &HC000&
        G.Enabled = False
        Set G = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Label.1", Left:=32 + WID * (I - 1), Top:=28, Width:=38, Height:=21)
        G.Name = "L" & I
        G.Object.Caption = ARR(I - 1)
        With G.Object.Font
            .Name = "隶书"
            .Size = 12
        End With
        G.Object.ForeColor = &HFF0000
        G.Object.BackColor = &HFFFFC0
    Next
    ZH
    ActiveSheet.Range("D3").Select
    Selection = 0
    Application.ScreenUpdating = True
End Sub

opelwang

非常感谢：zjdh 仁兄的帮忙，好好测试下再回复结果~~

zjdh

刚才疏忽了一个公式，7楼修改了！

opelwang

zjdh 发表于 2011-8-14 14:19
刚才疏忽了一个公式，7楼修改了！

测试了下，间距的问题解决了，但那个白边的问题仍然存在呀....