麻辣家族討論版版 - Powered by Discuz! Board

標題: 有關插入圖片的問題 [打印本頁]

作者: skyutm 時間: 2012-10-3 19:00 標題: 有關插入圖片的問題

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

作者: skyutm 時間: 2012-10-3 19:03

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

作者: skyutm 時間: 2012-10-4 22:22

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

作者: GBKEE 時間: 2012-10-5 08:22

回復 1# skyutm
試試看

[attach]12699[/attach]

作者: skyutm 時間: 2012-10-5 20:22

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

作者: skyutm 時間: 2012-10-5 20:29

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

作者: Hsieh 時間: 2012-10-5 22:18

回復 6# skyutm

模仿印章?

[attach]12708[/attach]

作者: GBKEE 時間: 2012-10-6 08:05

本帖最後由 GBKEE 於 2012-10-6 08:19 編輯

回復 6# skyutm
是這樣嗎?

Option Explicit
Sub Ex()
Dim Sh As Worksheet, 照片位置 As Range
Set Sh = ActiveSheet
Set 照片位置 = Sh.[d5]
With Sh
.Pictures.Delete '刪除工作表全部圖片(如還有其餘樣式的 Shape 會一併刪除)
With .[IV1]
.FormulaR1C1 = "李大" & Chr(10) & "明印"
.Font.Size = 14
.Font.ColorIndex = 3
.Font.Name = "華康古印體(P)" '修改你PC上的字體
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.MergeCells = False
.Copy
End With
With .Pictures.Paste
.Placement = xlMoveAndSize
.PrintObject = True
.Top = 照片位置.Top '圖片:頂端位置
.Left = 照片位置.Left '圖片:左邊位置
.ShapeRange.Fill.Visible = msoTrue '圖片背景顯示
' .ShapeRange.Fill.ForeColor.SchemeColor = 41 '背景顏色
.ShapeRange.Line.Visible = msoTrue '圖片邊框顯示
.ShapeRange.Line.Weight = 0.75 '邊框.厚度
' .ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.ForeColor.SchemeColor = 10 '圖片邊框.顏色
' .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
End With
.[IV1] = ""
End With
End Sub

複製代碼

作者: skyutm 時間: 2012-10-6 20:52

回復 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 時間: 2012-10-6 20:54

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

作者: skyutm 時間: 2012-10-7 18:53

回復 8# GBKEE
抱歉！版大又要打擾一下，小弟我想有關貼圖位置的語法應該是這一段吧
         .Top = 照片位置.Top                            '圖片:頂端位置
         .Left = 照片位置.Left                         '圖片:左邊位置
我想改成置中
         .center = 照片位置.center                         '圖片:頂端位置
         .cenetr = 照片位置.cenetr                         '圖片:左邊位置
或這樣
            .Top = 照片位置.center                            '圖片:頂端位置
            .Left = 照片位置.cenetr                         '圖片:左邊位置
或這樣
         .Top = 照片位置.xlcenetr                            '圖片:頂端位置
         .Left = 照片位置.xlcenetr                         '圖片:左邊位置
都不行，請問該如何修改呢？謝謝！

作者: stillfish00 時間: 2012-10-8 02:36

回復 11# skyutm
你可能誤會了 , Top和Left是指設定圖片上緣和左緣的座標位置 , 不是對齊方式~
置中一般是說文字在儲存格內的對齊方式 , 圖片應該沒這種設定?

作者: skyutm 時間: 2012-10-8 14:38

回復 12# stillfish00
是喔？那麼，那貼圖的位置是否有語法可以改變呢？

作者: GBKEE 時間: 2012-10-8 16:16

回復 13# skyutm

Option Explicit
Sub Ex()
Dim Sh As Worksheet, M(1 To 2) As String, E As Range
Set Sh = ActiveSheet
'Set 照片位置 = Sh.[d5]
With ActiveSheet
.Pictures.Delete '刪除工作表全部圖片(如還有其餘樣式的 Shape 會一併刪除)
For Each E In .[a1:a10] '*****[a1:a10] 已有姓名*****
M(1) = E
M(2) = Mid(E, 1, 2) & Chr(10) & Mid(E, 3, IIf(Len(E) < 3, 1, Len(E) - 2)) & "印"
With E
.FormulaR1C1 = M(2)
.Font.Size = 14
.Font.ColorIndex = 3
.Font.Name = "華康古印體(P)" '修改你PC上的字體
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.EntireRow.AutoFit '自動調整列高
.Copy
End With
With .Pictures.Paste
.Placement = xlMoveAndSize
.PrintObject = True
'*********** 圖片貼在[B1:B10] *******
.Top = E.Offset(, 1).Top '圖片:頂端位置
.Left = E.Offset(, 1).Left '圖片:左邊位置
E.Offset(, 1).RowHeight = E.RowHeight '圖片貼在[B1:B10] 調整列高
E.Offset(, 1).ColumnWidth = E.ColumnWidth '圖片貼在[B1:B10] 調整欄寬
'*********** 圖片貼在[B1:B10] *******
.ShapeRange.Fill.Visible = msoTrue '圖片背景顯示
' .ShapeRange.Fill.ForeColor.SchemeColor = 41 '背景顏色
.ShapeRange.Line.Visible = msoTrue '圖片邊框顯示
.ShapeRange.Line.Weight = 0.75 '邊框.厚度
' .ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.ForeColor.SchemeColor = 10 '圖片邊框.顏色
' .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
End With
E.Clear
E = M(1)
Next
End With
End Sub

複製代碼

作者: skyutm 時間: 2012-10-13 00:06

抱歉！還是要感謝版大熱心的教導，不過因為小弟覺得太複雜了。所以研究了這麼一段時間之後。我又去找了些語法，只是在圖片貼上之後，做一些調整移動。
With Sheets("成績單")
For i = 0 To j
         .Paste Destination:=.Range("d" & 22 + 26 * i)
         .Pictures.ShapeRange.IncrementLeft 45
         .Pictures.ShapeRange.IncrementTop 5
Next i
End With
但是又有問題ㄝ，因為迴圈會一直跑，所以會看到執行時，印章會一直不斷的移動，最前面的印章會移動最多次，甚至跑出範圍（由時會覺得很蠢！）所以又改成：
With Sheets("成績單")
For i = 0 To j
         .Paste Destination:=.Range("d" & 22 + 26 * i)
Next i
         .Pictures.ShapeRange.IncrementLeft 45
         .Pictures.ShapeRange.IncrementTop 5
End With
就是在迴圈跑完，印章都貼完之後，在一起移動圖片，但是，因為活頁簿裡也有其他圖片，所以也會跟著移動。真是傷腦筋。有沒有語法是在迴圈複製一張圖片之後，就立刻移動。下一張複製時就不會再移動到了？

作者: GBKEE 時間: 2012-10-13 08:07

本帖最後由 GBKEE 於 2012-10-13 08:24 編輯

回復 15# skyutm

With Sheets("成績單")
For i = 0 To j
.Paste Destination:=.Range("d" & 22 + 26 * i)
Next i
.Pictures.ShapeRange.IncrementLeft 45
.Pictures.ShapeRange.IncrementTop 5
'**** 也會跟著移動***** .Pictures -> Sheets("成績單")的所有圖片
End With

複製代碼

試試看

With Sheets("成績單")
For i = 0 To j
.Paste Destination:=.Range("d" & 22 + 26 * i)
a = .Pictures.Count
.Pictures(a).ShapeRange.IncrementLeft 45
.Pictures(a).ShapeRange.IncrementTop 5
Next i
End With

複製代碼

作者: skyutm 時間: 2012-10-13 20:27

回復 16# GBKEE

啊！我懂了，版大就是比較聰明（狗腿），把貼上的圖片加上編號，就可以準確控制已貼上圖片的移動位置，也就不會移動到其他圖片了。

作者: skyutm 時間: 2012-10-13 23:03

回復 16# GBKEE
抱歉！狗腿是有目的的，還有一個未解開的問題要請教！
小弟的構想是想要在成績輸入完成之後另存新檔，也在本論壇和網路上做過功課，修改後的語法如下
Sub macor24()
Dim a, b, u, v, r, n As String
a = Sheets("基本設定").Range("a6").Value
b = Sheets("基本設定").Range("a8").Value
u = Sheets("基本設定").Range("j1").Value
v = Sheets("基本設定").Range("j2").Value
r = "C:\Documents and Settings\Administrator\桌面\"
n = a & "學年度" & b & "學期" & u & "年" & v & "班成績檔"
Sheets("成績儲存").Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=r & n & ".xlsx", _
FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ThisWorkbook.Close savechanges:=True
End Sub
也如預期般可以在桌面存成另一個新檔，但是問題來了，因為這個工作表內有vba程式語法，所以另存新檔後，便會出現問題，就是有些語法會超出範圍，想請教一下，在複製工作表時有無選項，可以不用複製到裡面的語法嗎？再次感謝！

作者: GBKEE 時間: 2012-10-14 07:17

本帖最後由 GBKEE 於 2012-10-14 14:29 編輯

回復 18# skyutm
副檔名 .xlsx 為2003以上的版本存為無巨集的活頁簿應該沒有你說的問題

如是2003版可試試看如執行有錯誤請看 http://gb.twbts.com/index.php?topic=751.8

Sub macor24()
Dim a, b, u, v, r, n As String, xlVbc As Object
a = Sheets("基本設定").Range("a6").Value
b = Sheets("基本設定").Range("a8").Value
u = Sheets("基本設定").Range("j1").Value
v = Sheets("基本設定").Range("j2").Value
r = "C:\Documents and Settings\Administrator\桌面\"
n = a & "學年度" & b & "學期" & u & "年" & v & "班成績檔"
Sheets("成績儲存").Copy
Sheets(1).Copy
Application.DisplayAlerts = False
With ActiveWorkbook
For Each xlVbc In .VBProject.VBComponents
xlVbc.CodeModule.DeleteLines 1, xlVbc.CodeModule.CountOfLines
Next
.SaveAs Filename:=r & n & ".xls"
End With
ThisWorkbook.Close savechanges:=True
End Sub

複製代碼

作者: skyutm 時間: 2012-10-14 16:34

回復 19# GBKEE
版大您好！百忙之中又打擾了。您給的語法執行之後，還是會有語法在（所以會產生錯誤），而另外一個舊網頁所談的刪除工作表的巨集語法，在vba好像不能使用，最後小弟繞了一條遠路。就是：
1.先新增一新工作表
2.複製要複製的工作表
3.貼上時使用有條件的貼上選項（這樣就不上複製到工作表內的語法了）
PasteSpecial Paste:=xlPasteValues
PasteSpecial Paste:=xlPasteFormats
4.然後就是之前的語法
全部是
Sub macor24()
'解除保護「成績儲存」表格↓'
Sheets("成績儲存").Unprotect Password:="6323"
ActiveWorkbook.Unprotect Password:="6323"
'解除保護「成績儲存」表格↑'
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("成績儲存").Activate
Sheets("成績儲存").Cells.Copy
Sheets(Sheets.Count).Range("a1").PasteSpecial Paste:=xlPasteValues
Sheets("成績儲存").Activate
Sheets("成績儲存").Cells.Copy
Sheets(Sheets.Count).Range("a1").PasteSpecial Paste:=xlPasteFormats
Dim a, b, u, v, r, n As String
a = Sheets("基本設定").Range("a6").Value
b = Sheets("基本設定").Range("a8").Value
u = Sheets("基本設定").Range("j1").Value
v = Sheets("基本設定").Range("j2").Value
r = "C:\Documents and Settings\Administrator\桌面\"
n = a & "學年度" & b & "學期" & u & "年" & v & "班成績檔"
Sheets(Sheets.Count).Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=r & n & ".xls", _
FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Workbooks(1).Activate
Sheets(Sheets.Count).Delete
'保護「成績儲存」表格↓'
Sheets("成績儲存").Activate
ActiveSheet.EnableSelection = xlUnlockedCells
Sheets("成績儲存").Protect Password:="6323"
ActiveWorkbook.Protect Password:="6323"
'保護「成績儲存」表格↑'
Workbooks(2).Activate
ActiveWorkbook.Close savechanges:=True
End Sub
（抱歉！不是班門弄斧啦，想說以後有人需要，可以參考一下。）

作者: GBKEE 時間: 2012-10-14 16:41

回復 20# skyutm
語法執行之後，還是會有語法錯誤
是哪一行程式碼錯誤,錯誤值是多少,或是附檔看看.

作者: skyutm 時間: 2012-10-14 16:42

最後還是要說明一下！小弟的成績系統到目前為止可以說是全部完成。小弟的參考書目是：1.EXCEL超圖解VBA基礎講座2.EXCELVBA功能索引式參考手冊
另外要感謝的是兩位版大，一位是GBKEE一位是Hseih，還有論壇上各位熱心的先進，很多語法的知識，是在書上沒有辦法找到，如果沒有大家的協助，小弟可能要再花上更多的時間也無法完成，在這個你我不相識的網路世界，真是難能可貴之事，在此要再次表達感謝之意。謝謝大家的幫忙！（不是得獎感言啦）

作者: skyutm 時間: 2012-10-14 18:41

回復 21# GBKEE
版大你誤解了，因為那個工作表「成績儲存」，裡面的語法會需要其他工作表的資料，所以另存新檔後（重新建立一個只有工作表的檔案），語法就會出現超出索引值範圍（因為其他工作表不見了），所以並不是語法上的錯誤。

作者: GBKEE 時間: 2012-10-14 20:44

回復 23# skyutm
20# 的程式碼有修改空間

Option Explicit
Sub Ex() '練習試試看活頁簿,工作表: 須皆沒上鎖的狀態
Workbooks(1).Sheets(1).Copy ' Sheets(1) 請先製作VBA巨集
'Workbooks("TEST").Sheets("TEST").Copy ' Sheets(1) 請先製作VBA巨集
With ActiveWorkbook
Application.DisplayAlerts = False
.SaveAs "d:\無巨集.xlsx", FileFormat:=51 ' xlExcel8
'** 副檔名:xlsx 為無VBA巨集的活頁簿
Application.DisplayAlerts = False
End With
End Sub

複製代碼

作者: skyutm 時間: 2012-10-14 21:56

回復 24# GBKEE [
回版大，這個語法執行之後，另存的那個檔案裡面還是會有原來的語法存在。
作者: GBKEE 時間: 2012-10-15 08:07

回復 25# skyutm
請問你執行程式後有將此檔案關閉,然後在打開看看,此檔案依然是有巨集存在嗎?
再試試看
Sub Ex() '練習試試看活頁簿,工作表: 須皆沒上鎖的狀態

Workbooks(1).Sheets(1).Copy          ' Sheets(1) 請先製作VBA巨集

'Workbooks("TEST").Sheets("TEST").Copy ' Sheets(1) 請先製作VBA巨集

With ActiveWorkbook

      Application.DisplayAlerts = False

      .SaveAs "d:\無巨集.xlsx", FileFormat:=51 ' xlExcel8

      '**  副檔名:xlsx  為無VBA巨集的活頁簿

      Application.DisplayAlerts = False

      .Close

End With

Workbooks.Open ("d:\無巨集.xlsx")

End Sub
複製代碼
作者: skyutm 時間: 2012-10-15 18:07

回復 26# GBKEE
版大實在是太熱心了，鍥而不捨終於測試成功了，最後這個可以，檔案內已無巨集！
作者: skyutm 時間: 2012-10-15 19:40

回復 27# skyutm
版大您這麼一認真起來，我倒是有些被搞迷糊了。我比較了前後兩個語法只差在
Option Explicit
.Close
Workbooks.Open ("d:\無巨集.xlsx")
這三行而已，而我不懂，為何這樣語法的差異會造成不同的結果？
作者: GBKEE 時間: 2012-10-15 20:03

回復 28# skyutm
執行2 4# 的程式碼後須將檔案關閉,然後再打開才會無巨集
Workbooks(1).Sheets(1).Copy       '->複製Sheets(1) 的工作表會在新增的活頁簿

With ActiveWorkbook                   '>新增的活頁簿

      Application.DisplayAlerts = False

      .SaveAs "d:\無巨集.xlsx", FileFormat:=51 ' xlExcel8

   '**  副檔名:xlsx  為無VBA巨集的活頁簿

   '***'存檔後還是有巨集

      Application.DisplayAlerts = False

   .Close          '26#新加的程式碼  *** 關閉檔案

End With

Workbooks.Open ("d:\無巨集.xlsx") '26#新加的程式碼  *** 開啟檔案
複製代碼
作者: skyutm 時間: 2012-10-15 21:34

回復 29# GBKEE
回復版大，問題還是存在耶，因為剛剛實驗時是在新的檔案裡加幾行語法，結果檔案關閉後再重開語法就不見了。等到我運用在自己的成績系統之後，問題就出現了。因為被複製的工作表語法是寫在Worksheet_Activate裡，所以只要複製檔案時，還未關閉，語法錯誤行就會出現（還來不及關閉）。
後來我又想出一個辦法，就是在被複製的工作表語法裡面，加一行On Error Resume Next，這樣就可以解決了。（不知這樣有無風險嗎？）
作者: GBKEE 時間: 2012-10-16 06:39

回復 30# skyutm
加一行On Error Resume Next，這樣就可以解決了。（不知這樣有無風險嗎？）
是有的如有錯誤的語法或變數書寫錯誤, VBA是不處裡的.
請附檔看看
作者: skyutm 時間: 2012-10-16 17:06

回復 31# GBKEE
版大您好！再次感謝。附上檔案。工作表是「成績儲存」它是「學籍簿」工作表的複製。巨集是macro24
作者: GBKEE 時間: 2012-10-16 21:03

回復 32# skyutm
EnableEvents 屬性如果指定物件能觸發事件，則本屬性為 True。讀/寫 Boolean。
Sub macor24()

'解除保護「成績儲存」表格↓'

Application.EnableEvents = False  '停止物件能觸發事件

Sheets("成績儲存").Unprotect Password:="6323"

'解除保護「成績儲存」表格↑

Dim a, b, u, v, r, n As String

a = Sheets("基本設定").Range("a6").Value

b = Sheets("基本設定").Range("a8").Value

u = Sheets("基本設定").Range("j1").Value

v = Sheets("基本設定").Range("j2").Value

r = "C:\Documents and Settings\Administrator\桌面\"

n = a & "學年度" & b & "學期" & u & "年" & v & "班成績檔"

Sheets("成績儲存").Copy

With ActiveWorkbook

      Application.DisplayAlerts = False

      .SaveAs Filename:=r & n & ".xls", FileFormat:=51

      Application.DisplayAlerts = False

      '保護「成績儲存」表格↓'

      Sheets("成績儲存").Activate

      ActiveSheet.EnableSelection = xlUnlockedCells

      Sheets("成績儲存").Protect Password:="6323"

      '保護「成績儲存」表格↑'

      .Close savechanges:=True

End With

Application.EnableEvents = True '恢復物件能觸發事件

End Sub
複製代碼
Option Explicit

Sub Worksheet_Activate()

' ***  On Error Resume Next  可刪掉

Application.ScreenUpdating = False
複製代碼
作者: skyutm 時間: 2012-10-16 21:25

感謝版大！我又去網路上找了一下有關EnableEvents的資料，讓我多上了一課，也圓滿的解決這個問題了。

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)