圓戳章-增益集

by chijanzen on 一月 4th, 2010 | View: 27,144 views

Tags

Comments (41)

索引	C0011
主題	圓戳章-增益集 -新增 2007版
版本	>= 10.0(Office 2002)
說明	利用文字藝術師及橢圓快取圖案製作了圓戳章。經過VBA程式碼的處理，達成了以下幾點功能 1.可更換使用者名稱及字型 2.可更換圓戳章名稱，例如審核章、核准章..等 3.圓戳章的日期會自動更新為「本日」日期 4.新增3種日期格式可供選擇
參考

Code

Option Explicit
　

Private Sub Workbook_Open()
    Application.ScreenUpdating = False
    On Error Resume Next
    Call NewBarControl
    Application.ScreenUpdating = True
    CreateMenu
    If ThisWorkbook.Sheets("IconSheet").Range("Z1") <> "chijanzen" Then
        MsgBox "歡迎使用圓形章程式,第一次使用本程式需作基本資料設定"
        sealForm.Show
    End If
End Sub
　

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.CommandBars(3).Controls("圓戳章").Delete
    Call DeleteMenu
End Sub
　

Sub NewBarControl()
    On Error Resume Next
    ThisWorkbook.Sheets("IconSheet").Shapes("Icon").Copy
    Application.CommandBars(3).Controls("圓戳章").Delete
    With Application.CommandBars(3).Controls.Add
        .OnAction = "insertseal"
        .Caption = "圓戳章"
        .PasteFace        '將圖形Copy至按鈕上
        .Enabled = True
    End With
End Sub
　

Code

Sub insertseal()
    Dim shp As Shape
    '插入圓戳章
    Dim Item As Object
    On Error Resume Next
    '刪除已存在的圓戳章
    Set shp = ActiveSheet.Shapes("icon")
    If Not shp Is Nothing Then shp.Delete
    '插入圓戳章(日期為當日)
    With ThisWorkbook.Sheets("IconSheet").Shapes("icon")
        Select Case ThisWorkbook.Sheets("IconSheet").Range("Z2")
        Case 0
            Datestyle = "Yyyy/m/d"
        Case 1
            Datestyle = "[$-404]e"".""mm"".""dd;@"
        Case 2
            Datestyle = "[$-404]e""年""mm""月""dd""日"";@"
        Case Else
            Datestyle = "Yyyy/m/d"
        End Select
        .GroupItems.Item(6).TextEffect.Text = Format(Date, Datestyle)
        .Copy
        ActiveSheet.Paste
    End With
End Sub

Sub CreateMenu()
    Dim NewMenuItemMacro As String
    Dim NewMenuItem As String
    Dim XLCommandBar As Integer
    Dim NewItem As CommandBarButton
    Dim ToolsMenu As CommandBarPopup
    NewMenuItem = "圓戳章"
    Set ToolsMenu = Application.CommandBars(1). _
            FindControl(msoControlPopup, 30004)        '檢視
    On Error Resume Next
    ToolsMenu.Controls(NewMenuItem).Delete
    On Error GoTo 0
    ThisWorkbook.Sheets("IconSheet").Shapes("Icon").Copy
    Set NewItem = ToolsMenu.Controls.Add(Type:=msoControlButton)
    With NewItem
        .Caption = NewMenuItem
        .OnAction = "Setseal"
        .PasteFace        '將圖形Copy至按鈕上
        .BeginGroup = True
        .State = msoButtonDown
        .BeginGroup = True
    End With
    Exit Sub
End Sub

Sub Setseal()
sealForm.Show 0
End Sub

Sub DeleteMenu()
    Dim XLCommandBar As Integer
    Dim NewMenuItem As String
    Dim ToolsMenu As CommandBarPopup
    NewMenuItem = "圓戳章"
    Set ToolsMenu = Application.CommandBars(1). _
            FindControl(msoControlPopup, 30004)
    On Error Resume Next
    ToolsMenu.Controls(NewMenuItem).Delete
End Sub

Code

Private Sub CommandButton1_Click()
    Dim ShIco As Shape
    Dim ShIco1 As ShapeRange
    On Error Resume Next
    With ThisWorkbook.Sheets("IconSheet")
        '設定使用者姓名
        .Shapes("icon").GroupItems.Item(2).TextEffect.Text = Me.TextBox1
        '設定圓戳章名稱
        .Shapes("icon").GroupItems.Item(5).TextEffect.Text = Me.TextBox2
        '設定使用者姓名文字字型
        If CheckBox1 Then .Shapes("icon").GroupItems. _
                Item(2).TextEffect.FontName = Me.ComboBoxFont.Text
        '設定圓戳章名稱文字字型
        If CheckBox2 Then .Shapes("icon").GroupItems. _
                Item(5).TextEffect.FontName = Me.ComboBox1.Text
        If CheckBoxDate Then .Range("Z2") = Me.ComboBoxDate.ListIndex
        .Range("Z1") = "chijanzen"
        '儲存使用者名稱是否使用斜體
        'Shapes取消群組
        Set ShIco = .Shapes("icon")
        Set ShIco1 = ShIco.Ungroup
        If Me.OptfontItalicT = True Then
            ShIco1.Item(2).Adjustments.Item(1) = 0.52
        Else
            ShIco1.Item(2).Adjustments.Item(1) = 0.5
        End If
        'Shapes復原群組
        ShIco1.Regroup
        ShIco1.Name = "icon"
        .Range("Z1") = "chijanzen"
        '圖案在調整大小時保持其長寬比例不變
        .Shapes("icon").LockAspectRatio = msoTrue
        ThisWorkbook.Save
    End With
    MsgBox "恭喜你修改完成,已套用至圓戳章設定"
    Unload Me
    ThisWorkbook.Save
End Sub

Private Sub UserForm_Initialize()
    Dim CellLength As Long
    Dim i As Long
    Dim FontList As CommandBarComboBox
    With ThisWorkbook.Sheets("IconSheet")
        ChkNmae = .Range("Z1")
        Application.ScreenUpdating = False
        If ChkNmae = "chijanzen" Then
            Me.TextBox1 = .Shapes("icon").GroupItems.Item(2).TextEffect.Text
            Me.TextBox2 = .Shapes("icon").GroupItems.Item(5).TextEffect.Text
        Else
            TextBox1 = "chijanzen"
            TextBox2 = "審核章"
        End If
    End With
    On Error Resume Next
    Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)
    If Err = 0 Then
        ReDim CSArray(1 To FontList.ListCount)
        ReDim FontArray(1 To FontList.ListCount)
        '列出Excel內建字型
        With ComboBoxFont
            For i = 1 To FontList.ListCount
                FontArray(i) = FontList.List(i)
                .AddItem FontList.List(i)
            Next i
            If ThisWorkbook.Sheets("IconSheet").Range("Z1") = "chijanzen" Then
                .Text = ThisWorkbook.Sheets("IconSheet").Shapes("icon"). _
                        GroupItems.Item(2).TextEffect.FontName
            Else
                fnt = Application.StandardFont        'Excel 預設字型
                .Text = fnt
            End If
        End With
        '列出字型大小
        With ComboBox1
            For i = 1 To FontList.ListCount
                FontArray(i) = FontList.List(i)
                .AddItem FontList.List(i)
            Next i
            If ThisWorkbook.Sheets("IconSheet").Range("Z1") = "chijanzen" Then
                .Text = ThisWorkbook.Sheets("IconSheet").Shapes("icon"). _
                        GroupItems.Item(5).TextEffect.FontName
            Else
                fnt = Application.StandardFont
                .Text = fnt
            End If
        End With
        '列出日期格式
        With ComboBoxDate
            .AddItem Format(Date, "Yyyy/m/d")
            .AddItem Format(Date, "[$-404]e"".""mm"".""dd;@")
            .AddItem Format(Date, "[$-404]e""年""mm""月""dd""日"";@")
            If ThisWorkbook.Sheets("IconSheet").Range("Z1") = "chijanzen" Then
                .Text = ThisWorkbook.Sheets("IconSheet").Shapes("icon"). _
                        GroupItems.Item(6).TextEffect.Text
            Else
                fnt = Format(Date, "Yyyy/m/d")
                .Text = fnt
            End If
        End With
        '使用者名稱預設為斜體
        OptfontItalicT = True
    End If
End Sub

Help

Code

附件內有兩個檔案，請解壓縮到同一資料夾內，請執行安裝程式

VBE 密碼:chijanzen

DownLoad

Code

Excel 2003 版以前檔案下載
Excel 2007 版檔案下載

Excel 2007 版製作，請參考

　

你好:

我就講解一下如何顯示在工作表中的圓戳章原稿

如果你已經安裝圓戳章，請在Excel畫面按 Alt + F11 鍵切換到VBE編輯視窗

選取 VBAProject(seal.xla)，然後用滑鼠點兩下，會出現要輸入密碼的方塊，請輸入VBE密碼 chijanzen 或 1234

到 ThisWorkBook 模組並找到 IsAddin 將屬性 True 改為 False，這時後 seal.xla 就後出現在Excel視窗中了

請切換到Excel 你就會在 IconSheet 工作表中找到圓戳章了，ok 完成了

當你改完後記得用再將IsAddin 將屬性改為 False

　

Popularity: 76%

About the Author

網路化名: chijanzen、中國龍、邪兵衛經歷: 第二屆微軟社群之星第三屆微軟「最有價值專家」第五屆微軟「最有價值專家」

Leave a Comment »41 Comments

Reply » Ming 八月 27, 2010

您好：
想請教一下
1.日期如果不想要顯示的話，要怎麼拿掉，只顯示人名及審查章等字樣？
2.要怎麼多重安裝圓戳章？有時會有需要同時蓋好幾個章的需求？我有試著改了一點程式，另外增加一個seal02.xla，不過會怪怪的，沒辦法設定兩個人名，都只會抓到一個。工具列是有出現兩個，不過一個有圖形，一個是空白的。
想了許久實在試不出來，請您指點一下，謝謝。
Reply » 高錦隆八月 7, 2010

我是從事營建工程管理在工地常有各種報表要填寫記載如何在excel 各報表的右上角設一個"icone"或是"按鑑"就能新增次頁且能連結前一頁的各項資料且列印時該按鍵不會列印出來
Reply » chen 七月 22, 2010

因為安裝<圓戳章>有下列問題請教
我是使用2007版的
我將程式放在桌面上直接執行 "installaddin" 然後按下 "install" 並按下 "確認"
結果出現一新視窗其內容為 "檔案複製失敗,請再檢查檔名或路徑是否正確"
我可以確定解壓縮後是兩個程式另一個是 "seal"
因為不知是哪裡出問題所以冒昧請教,還請指正.謝謝
- Reply » chijanzen 七月 23, 2010
  
  你好:
  
  可能是權限的問題，請你將seal.xlam手動複製到 excel 2007 資量夾中
  
  C:\Program Files\Microsoft Office\Office13\LIBRARY
  
  如果是excel 2010版則是手動複製到
  
  C:\Program Files\Microsoft Office\Office14\LIBRARY
  
  檔案確定複製到LIBRARY資料夾後，請再下載以下的增益集啟用程式，一樣按Install安裝
  
  檔案下載:http://chijanzen.net/file/Installseal.rar
Reply » vivien 六月 22, 2010

我下載2007板,要安裝時顯示無法執行巨集,
請問我應該怎麼做才能安裝?
Reply » phoebe 四月 28, 2010

找～安裝後發現！～

檔案複製失敗～請檢查檔名路徑是否正確～

直接執行～SEAL是可以用～但是關掉以後就沒有了！～

我是win 7的系統 2003版
爬過文～但是還是沒懂！

感謝大俠相救！skype～gpi_phoebe~
Reply » ming 三月 15, 2010

請教一下，戳章要怎麼改成直式長方形，內容為一行或兩行字？
Reply » 工程師三月 8, 2010

請問怎麼改成插入數字圈圈的呢？謝謝
Reply » chijanzen 一月 4, 2010

圓戳章增益集已新增功能，請到首頁重新下載

或按此下載

新增:

1.可選擇日期格式

2.姓名可設定斜體或正常，已下程式碼是關鍵

ShIco1.Regroup
ShIco1.Name = "icon"
.Range("Z1") = "chijanzen"
'圖案在調整大小時保持其長寬比例不變
.Shapes("icon").LockAspectRatio = msoTrue
Reply » GINO 一月 4, 2010

謝謝你幫忙
但還是要再打擾你真不好意思
1.99.1.3您的回覆網址::Http://FileDeck.net/files/TCU5XX5M/seal.rar無法下儎可否將檔案mail給我感激囉
2.原想將你提供的修改程式coppy到原編輯貼上但依您的提示輸入1234或chijanzen均無法開啟
是密碼有修改嗎?
不好意思再麻煩您了感恩
Reply » GINO 一月 3, 2010

很感激你快速的協助解決問題感恩囉
尚有個問題想再麻煩您:
1.不管哪種字體可否不要傾斜(現有字體稍微傾斜)
2.日期的字型在圓戳章工具選項可否多2個選項:a字型 b格式:例如99.01.03 或99年1月3日
感恩啦謝謝您無私幫忙謝謝!

Reply » GINO 一月 1, 2010

圓戳章內的日期格式可否改為:99.01.01. 謝謝!

Reply » chijanzen 一月 1, 2010

你好:
將這段程式碼

    With ThisWorkbook.Sheets("IconSheet").Shapes("icon")
        .GroupItems.Item(6).TextEffect.Text = Format(Date, "Yyyy/m/d")
        .Copy
        ActiveSheet.Paste
    End With

修改為以下

    With ThisWorkbook.Sheets("IconSheet").Shapes("icon")
        .GroupItems.Item(6).TextEffect.Text = Format(Date, "[$-404]e"".""mm"".""dd;@")
        .Copy
        ActiveSheet.Paste
    End With

檔案下載:Http://FileDeck.net/files/TCU5XX5M/seal.rar

Reply » GINO 一月 1, 2010

圓戳章內的字體在軟體程式內如何改正(不要解除群組再調整傾斜度)

Reply » chijanzen 一月 1, 2010

你好:
以下這段程式碼就是在設定字型的

    With ThisWorkbook.Sheets("IconSheet")
        '設定使用者姓名文字字型
        If CheckBox1 Then .Shapes("icon").GroupItems. _
                Item(2).TextEffect.FontName = "細明體"
        '設定圓戳章名稱文字字型
        If CheckBox2 Then .Shapes("icon").GroupItems. _
                Item(5).TextEffect.FontName = "細明體"
     End With

Reply » chijanzen 十一月 12, 2009

小湯:
請看以下第3調說明

1.請你開啟 InstallAddin.xls 按下 install，程式會自動安裝，如果要移除請按 uninstall
2.第一次安裝會讓你設定姓名及字型，如果以後還要更改請在工具列=>檢視=>按一下圓戳章就能更改了
3.若圓戳章會消失請到工具列=>工具=>增益集=>勾選圓戳章即可
4.插入圓戳章及本上只會顯示當天日期，沒有地方可以更改。你可以選取作表上的圓搓章右鍵=>群組物件=>取消群組就能自己改日期了
Reply » 小湯十一月 12, 2009

安裝InstallAddin.xls 按下 install時他說路徑不存在ㄟ，但是我第一次可以跑出圓戳章第二次之後都不行!我是2003版本，可以教教我嗎?謝謝
Reply » Jessy 九月 29, 2009

我覺得蠻不錯的喔!如果可以直接應用在WORD上(而不是利用複製)就更棒了!
Reply » ann1018 八月 14, 2009

不好意思想在這裡問個問題

excel2007開啟excel2007也是
Microsoft ActiveX Data Objects 2.X Library 嗎??

2007的副檔名是".xlsm"

為什麼我試都不行??
Reply » Alin 八月 4, 2009

安裝InstallAddin.xls 按下 install時他說路徑不存在ㄟ，但是我第一次可以跑出圓戳章第二次之後都不行!我是2003版本，可以教教我嗎?謝謝
- Reply » chijanzen 八月 23, 2009
  
  test
  - Reply » chijanzen 八月 23, 2009
    
    第三階
    - chijanzen 八月 23, 2009
      
      第四階
Reply » chijanzen 七月 30, 2009

你好:
請你開啟 InstallAddin.xls 按下 install，程式會自動安裝，如果要移除請按 uninstall
Reply » red~ 七月 30, 2009

你好...我不曉得安裝哪裡出了問題...結果我現在excel都開不了了...怎麼辦...如果要移除這個巨集..要怎麼移除呢?
快解救我啊.....
Reply » chijanzen 七月 11, 2009

只能將工作表保護起來了，沒有其他的方法
Reply » Dennis 七月 11, 2009

請問如何讓它可以鎖定!其他人不是會修改或複製走ㄟ??
Reply » chijanzen 七月 11, 2009

你好:
那是因為你的巨集安全性調到最高所以無法執行巨集，建議你將安全性調到中，然後再選擇要不要啟用巨集
工具=> 巨集 => 安全性 => 選擇中，然後關閉Excel再啟動一次
Reply » red~ 七月 11, 2009

為什麼我會出現這一行字呢....沒辦法安裝 = =.....''在這個活頁簿中的巨集停用了，因為安全性層級高，而巨集沒有電子簽章或檢驗為安全。要執行巨集，您可以使用電子簽章或變更安全性層級。''
Reply » 魚～六月 6, 2009

你好～
請問一下如果我的office沒有增益及該怎麼辦呢？？
之前我的office好像出了點問題
我移除後就從網路下載了office
沒想到這一版的無增益集
可是要交作業需要增益集裡的功能～好煩惱阿
可不可以幫幫我好煩惱阿～！
Reply » acrazy 十一月 12, 2008

請問使用者姓名字體能改為其他種類嗎? 謝謝!
Reply » chijanzen 十月 22, 2008

你好:
請問你有是裝2003版的吧!
1.請你開啟 InstallAddin.xls 按下 install，程式會自動安裝，如果要移除請按 uninstall
2.第一次安裝會讓你設定姓名及字型，如果以後還要更改請在工具列=>檢視=>按一下圓戳章就能更改了
3.若圓戳章會消失請到工具列=>工具=>增益集=>勾選圓戳章即可
4.插入圓戳章及本上只會顯示當天日期，沒有地方可以更改。你可以選取作表上的圓搓章右鍵=>群組物件=>取消群組就能自己改日期了
Reply » JUDY 十月 22, 2008

請問
如果已經安裝完成後,想要修改戳章內容(日期 OR 姓名....)
要到哪裡設定,我現在是採重新安裝.
另外有時候小戳章會消失,但又無法從工具列叫出來,該如何處理(我還是只會重新安裝這一招)
Reply » chijanzen 十月 15, 2008
你好:

我就講解一下如何顯示在工作表中的圓戳章原稿
- 如果你已經安裝圓戳章，請在Excel畫面按 Alt + F11 鍵切換到VBE編輯視窗
- 選取 VBAProject(seal.xla)，然後用滑鼠點兩下，會出現要輸入密碼的方塊，請輸入VBE密碼 chijanzen 或 1234
- 到 ThisWorkBook 模組並找到 IsAddin 將屬性 True 改為 False，這時後 seal.xla 就後出現在Excel視窗中了
- 請切換到Excel 你就會在 IconSheet 工作表中找到圓戳章了，ok 完成了
- 當你改完後記得用再將IsAddin 將屬性改為 False
　
Reply » kentung 十月 15, 2008

請問，shapes如何套入主程式中？因多次嘗試仍不得其解，可否惠予賜教？
Reply » chijanzen 九月 2, 2008

今天找了2台Excel 2007來測試，結果都能正常使用
跟你回報一下
Reply » chijanzen 八月 19, 2008

你好:
2005.10.31 是這個圓戳章上的原始日期
我在XP 及 2000 測試都沒問題
因為版權的問題，我沒灌 2007
我會去借一台有2007的來試試
有結果會再來回覆你
Reply » wang 八月 19, 2008

請問使用office 2007
不知為何日期顯示不正確
顯示為 2005.10.31
Reply » chijanzen 八月 12, 2008

你好:
這個增益集只能使用在Excel
但是圓戳章可以複製到 Word 使用
Reply » Simon 八月 11, 2008

請問增益集可被Word使用嗎?

Get a GravatarLeave a Reply

Blue Green Grey Orange Purple Red

chijanzen 雜貨舖

圓戳章-增益集

Help

DownLoad