1234
返回列表 上一主題 發帖

有關插入圖片的問題

skyutm

帖子
84 
主題
13 
精華
0 
積分
104 
點名
0  
作業系統
XP 
軟體版本
SP3 
閱讀權限
20 
性別
男 
註冊時間
2012-8-10 
最後登錄
2018-4-21 
11# 跳轉到 »
發表於 2012-10-7 18:53 | 只看該作者
回復 8# GBKEE
抱歉！版大又要打擾一下，小弟我想有關貼圖位置的語法應該是這一段吧
            .Top = 照片位置.Top                             '圖片:頂端位置
            .Left = 照片位置.Left                           '圖片:左邊位置
我想改成置中
            .center = 照片位置.center                            '圖片:頂端位置
            .cenetr = 照片位置.cenetr                           '圖片:左邊位置
或這樣
                .Top = 照片位置.center                             '圖片:頂端位置
               .Left = 照片位置.cenetr                           '圖片:左邊位置
或這樣
            .Top = 照片位置.xlcenetr                             '圖片:頂端位置
            .Left = 照片位置.xlcenetr                           '圖片:左邊位置
都不行，請問該如何修改呢？謝謝！

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
12#
發表於 2012-10-8 02:36 | 只看該作者
回復 11# skyutm
你可能誤會了 , Top和Left是指設定圖片上緣和左緣的座標位置 , 不是對齊方式~
置中一般是說文字在儲存格內的對齊方式 , 圖片應該沒這種設定?

TOP

skyutm

帖子
84 
主題
13 
精華
0 
積分
104 
點名
0  
作業系統
XP 
軟體版本
SP3 
閱讀權限
20 
性別
男 
註冊時間
2012-8-10 
最後登錄
2018-4-21 
13#
發表於 2012-10-8 14:38 | 只看該作者
回復 12# stillfish00
是喔？那麼，那貼圖的位置是否有語法可以改變呢？

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
14#
發表於 2012-10-8 16:16 | 只看該作者
回復 13# skyutm
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Sh As Worksheet, M(1 To 2) As String, E As Range
  4.     Set Sh = ActiveSheet
  5.     'Set 照片位置 = Sh.[d5]
  6.     With ActiveSheet
  7.         .Pictures.Delete                                    '刪除工作表全部圖片(如還有其餘樣式的 Shape 會一併刪除)
  8.         For Each E In .[a1:a10]                            '*****[a1:a10] 已有姓名*****
  9.             M(1) = E
  10.             M(2) = Mid(E, 1, 2) & Chr(10) & Mid(E, 3, IIf(Len(E) < 3, 1, Len(E) - 2)) & "印"
  11.             With E
  12.             .FormulaR1C1 = M(2)
  13.             .Font.Size = 14
  14.             .Font.ColorIndex = 3
  15.             .Font.Name = "華康古印體(P)"                    '修改你PC上的字體
  16.             .HorizontalAlignment = xlCenter
  17.             .VerticalAlignment = xlCenter
  18.             .WrapText = True
  19.             .EntireRow.AutoFit                              '自動調整列高
  20.             .Copy
  21.         End With
  22.         With .Pictures.Paste
  23.             .Placement = xlMoveAndSize
  24.             .PrintObject = True
  25.             
  26.             '*********** 圖片貼在[B1:B10]     *******
  27.             .Top = E.Offset(, 1).Top                        '圖片:頂端位置
  28.             .Left = E.Offset(, 1).Left                      '圖片:左邊位置
  29.             E.Offset(, 1).RowHeight = E.RowHeight           '圖片貼在[B1:B10] 調整 列高
  30.             E.Offset(, 1).ColumnWidth = E.ColumnWidth       '圖片貼在[B1:B10] 調整 欄寬
  31.              '*********** 圖片貼在[B1:B10]     *******
  32.             
  33.             .ShapeRange.Fill.Visible = msoTrue              '圖片背景 顯示
  34.            ' .ShapeRange.Fill.ForeColor.SchemeColor = 41    '背景顏色
  35.              .ShapeRange.Line.Visible = msoTrue             '圖片邊框 顯示
  36.             .ShapeRange.Line.Weight = 0.75                  '邊框.厚度
  37.           '  .ShapeRange.Line.Visible = msoTrue
  38.             .ShapeRange.Line.ForeColor.SchemeColor = 10     '圖片邊框.顏色
  39.          '   .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
  40.         End With
  41.         E.Clear
  42.         E = M(1)
  43.         Next
  44.     End With
  45. End Sub
複製代碼

TOP

skyutm

帖子
84 
主題
13 
精華
0 
積分
104 
點名
0  
作業系統
XP 
軟體版本
SP3 
閱讀權限
20 
性別
男 
註冊時間
2012-8-10 
最後登錄
2018-4-21 
15#
發表於 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
就是在迴圈跑完，印章都貼完之後，在一起移動圖片，但是，因為活頁簿裡也有其他圖片，所以也會跟著移動。真是傷腦筋。有沒有語法是在迴圈複製一張圖片之後，就立刻移動。下一張複製時就不會再移動到了？

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
16#
發表於 2012-10-13 08:07 | 只看該作者
本帖最後由 GBKEE 於 2012-10-13 08:24 編輯

回復 15# skyutm
  1. With Sheets("成績單")
  2.     For i = 0 To j
  3.              .Paste Destination:=.Range("d" & 22 + 26 * i)
  4.     Next i
  5.              .Pictures.ShapeRange.IncrementLeft 45
  6.              .Pictures.ShapeRange.IncrementTop 5
  7.            '**** 也會跟著移動*****       .Pictures -> Sheets("成績單")的所有圖片
  8.     End With
複製代碼
試試看
  1. With Sheets("成績單")
  2.     For i = 0 To j
  3.              .Paste Destination:=.Range("d" & 22 + 26 * i)
  4.               a = .Pictures.Count
  5.              .Pictures(a).ShapeRange.IncrementLeft 45
  6.              .Pictures(a).ShapeRange.IncrementTop 5
  7.     Next i
  8.     End With
複製代碼

TOP

skyutm

帖子
84 
主題
13 
精華
0 
積分
104 
點名
0  
作業系統
XP 
軟體版本
SP3 
閱讀權限
20 
性別
男 
註冊時間
2012-8-10 
最後登錄
2018-4-21 
17#
發表於 2012-10-13 20:27 | 只看該作者
回復 16# GBKEE

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

TOP

skyutm

帖子
84 
主題
13 
精華
0 
積分
104 
點名
0  
作業系統
XP 
軟體版本
SP3 
閱讀權限
20 
性別
男 
註冊時間
2012-8-10 
最後登錄
2018-4-21 
18#
發表於 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程式語法，所以另存新檔後，便會出現問題，就是有些語法會超出範圍，想請教一下，在複製工作表時有無選項，可以不用複製到裡面的語法嗎？再次感謝！

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
19#
發表於 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
  1. Sub macor24()
  2.     Dim a, b, u, v, r, n As String, xlVbc As Object
  3.     a = Sheets("基本設定").Range("a6").Value
  4.     b = Sheets("基本設定").Range("a8").Value
  5.     u = Sheets("基本設定").Range("j1").Value
  6.     v = Sheets("基本設定").Range("j2").Value
  7.     r = "C:\Documents and Settings\Administrator\桌面\"
  8.     n = a & "學年度" & b & "學期" & u & "年" & v & "班成績檔"
  9.     Sheets("成績儲存").Copy
  10.     Sheets(1).Copy
  11.     Application.DisplayAlerts = False
  12.     With ActiveWorkbook
  13.         For Each xlVbc In .VBProject.VBComponents
  14.             xlVbc.CodeModule.DeleteLines 1, xlVbc.CodeModule.CountOfLines
  15.         Next
  16.         .SaveAs Filename:=r & n & ".xls"
  17.     End With
  18.     ThisWorkbook.Close savechanges:=True
  19. End Sub
複製代碼

TOP

skyutm

帖子
84 
主題
13 
精華
0 
積分
104 
點名
0  
作業系統
XP 
軟體版本
SP3 
閱讀權限
20 
性別
男 
註冊時間
2012-8-10 
最後登錄
2018-4-21 
20#
發表於 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
（抱歉！不是班門弄斧啦，想說以後有人需要，可以參考一下。）

TOP

        靜思自在 : 愛不是要求對方，而是要由自身的付出。
1234
返回列表 上一主題