有關插入圖片的問題

skyutm

各位先進大家好！
        不好意思！小弟又來打擾了。小弟的問題是：我在活頁簿裡插入很多張同樣的圖片（學校的校徽），每隔幾行就會出現一張，但是在語法裡有隱藏行列的語法：
    .Cells.Rows.Hidden = False
    .Range("a" & 1 + 26 * k, .Range("a1041")).EntireRow.Hidden = True
    .Range("a1041", Range("a1041").End(xlDown)).EntireRow.Hidden = True
問題在於，有圖片的行列被隱藏，一旦又被取消隱藏之後，就會發現圖片被壓縮了。不知這個問題如何解決呢？

skyutm

檔案在此，是最右邊「成績單」這個活頁簿，再次感謝！
http://www.funp.net/653900

skyutm

不好意思！小弟已經在網路上和書上找到解決的方法。就是先不要複製圖片。等到隱藏儲存格的語法跑完。再來跑複製圖片的語法。這樣圖片就不會被壓縮了。

GBKEE

回復 1# skyutm
試試看

下載 (53.55 KB)

2012-10-5 08:22

skyutm

回復 4# GBKEE
唉呀！我怎麼花費這麼多時間在這兒，原來只要把選項改一改就好了，害我寫了一堆語法。不過我也從中學了一些。
像這樣先刪除圖片，以免第二次開活頁簿就會出現圖片大堆疊
    ActiveSheet.Shapes.SelectAll
    Selection.Delete
再來就是在另一個活頁簿貼圖，從那兒複製過來
     Sheets("sheet1").Shapes(1).Copy
     ActiveSheet.Paste Destination:=Sheets("成績單").Range("a" & 1 + 26 * j)

skyutm

回復 4# GBKEE
版主大大，真是感謝，不過另外小弟又有一事相求，就是我想營造印章的感覺。
1.原本是利用文字藝術師，例如輸入 王大明，就會出現
王大
明印
但是文字藝術師無法強迫換行，所以做罷！文字藝術師只能出現  王大明印，要換行要手動去調整框框大小
2第二我是用儲存格大小與自動換行來設定，但是到了要輸出的儲存格，又會自己改變格式，所以還在另想辦法，可否以高深的功力相助？.

Hsieh

回復 6# skyutm

模仿印章?

   

下載 (44.86 KB)

2012-10-5 22:18

GBKEE

回復 6# skyutm
是這樣嗎?

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Sh As Worksheet, 照片位置 As Range
   
4.     Set Sh = ActiveSheet
   
5.     Set 照片位置 = Sh.[d5]
   
6.     With Sh
   
7.         .Pictures.Delete                                    '刪除工作表全部圖片(如還有其餘樣式的 Shape 會一併刪除)
   
8.         With .[IV1]
   
9.             .FormulaR1C1 = "李大" & Chr(10) & "明印"
   
10.             .Font.Size = 14
    
11.             .Font.ColorIndex = 3
    
12.             .Font.Name = "華康古印體(P)"                    '修改你PC上的字體
    
13.             .HorizontalAlignment = xlCenter
    
14.             .VerticalAlignment = xlCenter
    
15.             .WrapText = True
    
16.             .MergeCells = False
    
17.             .Copy
    
18.         End With
    
19.         With .Pictures.Paste
    
20.             .Placement = xlMoveAndSize
    
21.             .PrintObject = True
    
22.             .Top = 照片位置.Top                             '圖片:頂端位置
    
23.             .Left = 照片位置.Left                           '圖片:左邊位置
    
24.             .ShapeRange.Fill.Visible = msoTrue              '圖片背景 顯示
    
25.            ' .ShapeRange.Fill.ForeColor.SchemeColor = 41    '背景顏色
    
26.              .ShapeRange.Line.Visible = msoTrue             '圖片邊框 顯示
    
27.             .ShapeRange.Line.Weight = 0.75                  '邊框.厚度
    
28.           '  .ShapeRange.Line.Visible = msoTrue
    
29.             .ShapeRange.Line.ForeColor.SchemeColor = 10     '圖片邊框.顏色
    
30.          '   .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    
31.         End With
    
32.         .[IV1] = ""
    
33.     End With
    
34. End Sub

複製代碼

skyutm

回復 8# GBKEE
哇哈哈！終於讓我有機會「班門弄斧」啦。
小弟不才，但是讓我找到了mid函數，我利用mid將姓名字串分割。所以就加了一些語法：
Option Explicit
Sub Worksheet_Activate()
    Dim a, b, c As String, Sh As Worksheet, Pr As Range
    a = Sheets("基本設定").Range("i5").Value  '已輸入的姓名欄
    b = Mid(a, 1, 2)    '分割姓名
    c = Mid(a, 3, 1)    '分割姓名
    Set Sh = Sheets("印章")
    Set Pr = Sh.[b1]
    With Sh
        With .[a10]
             .FormulaR1C1 = b & Chr(10) & c & "印"      '把姓名前兩字和最後一字加上印強迫換行
             .Font.Size = 15
             .Font.ColorIndex = 3
             .Font.Name = "華康古印體(P)"
             .HorizontalAlignment = xlCenter
             .VerticalAlignment = xlCenter
             .WrapText = True
             .MergeCells = False
             .Copy
        End With
        With .Pictures.Paste
             .Placement = xlMoveAndSize
             .PrintObject = True
             .Top = Pr.Top
             .Left = Pr.Left
             .ShapeRange.Fill.Visible = msoFalse
             .ShapeRange.Line.Visible = msoFalse
             .ShapeRange.Line.Weight = 1
             .ShapeRange.Line.ForeColor.SchemeColor = 10
             .Select
        End With
        .[a10] = ""
    End With
End Sub

skyutm

不過還是要感謝超熱心的兩位版大，這真是其他論壇無法比擬的！