none
EXCEL VBA による画像又は写真貼り付けについて RRS feed

  • 質問

  • EXCEL VBAで写真を台紙に貼り付けようとしています。
    台紙は1ページ3列30行で構成され、A1~A9,A11~A19,A21~A29のセルが結合セルに設定され、
    そこに写真を貼り付けるように設定されています。
    C列にはA1~A9の写真に該当する名称はC4,C6に、A11~A19の写真に該当する名称はC14,C16に、
    A21~A29の写真に該当する名称はC24,C26に各々設定されています。
    B列は写真と写真名称の間を埋める隙間として設定されており、何も設定していません。
    今、この1ページ構成で1シート上に80ページ分設けて台紙シートとしてあります。
    列方向に80ページの構成としていますので、最終使用列はIF列になります。
    この台紙はユーザが作成設定してきており、どの位置にどの写真を貼り付けるのかの指定がされています。

    問題は以下のコードで指定されたセルに対象の画像を貼り付けようとしたとき、改ページプレビューで見たときの
    ページ表示が最大列数を超えるような表示に一時的になったときに、指定セルに正しく画像が設定できないという現象が
    発生しているのです。
    以下が画像貼り付けに使用しているコードです。
      Set Movcell = disBOOK.Worksheets(dissheet_NAME).Cells(prow, pcol)
      '********** 目的の位置・セルのサイズのセット ********
      With Movcell
         'テスト追加分
         Set Pic = disBOOK.Worksheets(dissheet_NAME).Shapes.AddPicture( _
         Filename:=myPICTURE_PATH_FILE_NAME, LinkToFile:=False, _
         SaveWithDocument:=True, _
         Left:=.Left + 2, _
         Top:=.Top + 2, _
         Width:=.MergeArea.Width, _
         Height:=.MergeArea.Height)
      End With
    prow, pcolには写真を貼り付ける結合されたセルの先頭部分の位置が設定されています。
    myPICTURE_PATH_FILE_NAMEには画像のフルパス名が設定されています。

    どのような動作結果になるかというと、48ページ以降のページには正しく画像が貼り付きません。
    48ページのところから少しずれた位置に以降の画像が全て重なって貼り付いてしまいます。
    Application.ScreenUpdating = False
    にしても、現象は変わりません。

    上記コードの直後に該当のセルへmyPICTURE_PATH_FILE_NAMEを設定する処理を追加してみたところ
    その処理は正しく動作できています。単に画像のみが正しく設定できないという現象です。

    原因ないし、対処方法がお分かりの方お教え願えないでしょうか。
    宜しくお願いします。

    2011年10月4日 6:10

すべての返信

  • 試したところ、AddPicrureのLeftは、6000位が上限になってしまっているみたいです。(バグ?)
    おそらく対象になっているWorksheetだと48ページでこの上限に達しているために、以降の画像が重なってしまっているのだと思います。
    この現象はShape.IncrementLeftで配置しなおすことでこの上限は回避できるみたいです。

    ですが、もう1個不具合があって、Range.Leftがどうもずれて取得されるようです。
    そのため、セルのColumnIndexが大きくなると誤差がかなりできてしまいします。
    こっちはとりあえずは誤差の修正処理するように計算すれば回避できそうですが、誤差の修正の計算が本当に正しいのかまでは判りません。
    とりあえず250列ぐらいまでは誤差修正できているようなので、使えないことはなさそうです。
    #もしかしたらRange.Leftは罫線の幅が考慮されてないのかもしれない…

     

    Sub test()
        Dim x As Integer
        Dim y As Integer
        
        For y = 0 To 2
            For x = 0 To 79
                InsertImage x * 3 + 1, y * 10 + 1
            Next
        Next
    End Sub
    
    Sub InsertImage(ByVal pcol As Integer, ByVal prow As Integer)
        Dim myPICTURE_PATH_FILE_NAME As String
        Dim dissheet_NAME As String
        myPICTURE_PATH_FILE_NAME = "てすと.png"
        dissheet_NAME = "Sheet1"
        
        Dim disBOOK As Workbook
        Dim disSheet As Worksheet
        Dim Movcell As Range
        
        Set disBOOK = ActiveWorkbook
        Set disSheet = disBOOK.Sheets(dissheet_NAME)
        Set Movcell = disSheet.Cells(prow, pcol)
        
        Dim pic As Shape
    
        '********** 目的の位置・セルのサイズのセット ********
        With Movcell
            Dim dbl As Double
            dbl = CalcX(disSheet, pcol)
        
            Dim sX As Single
            Dim sY As Single
            sX = dbl 'Movcell.Left 誤差があるので補正した値を使う
            sY = Movcell.Top
            
            
            'テスト追加分
            Set pic = disSheet.Shapes.AddPicture( _
                        Filename:=myPICTURE_PATH_FILE_NAME, _
                        LinkToFile:=False, _
                        SaveWithDocument:=True, _
                        Left:=0, _
                        Top:=0, _
                        Width:=.MergeArea.Width, _
                        Height:=.MergeArea.Height)
                        
            pic.Left = 0
            pic.Top = 0
    
            'AddPictureだとXは6000位が上限になってしまうようなのでIncrementLeftで配置
            Call pic.IncrementTop(sY)
            Call pic.IncrementLeft(sX)
    
            Debug.Print sX
        End With
    End Sub
    
    Function CalcX(ByVal sh As Worksheet, ByVal colIndex As Integer) As Single
        Dim rng1 As Range
        Dim rng2 As Range
        Dim r As Range
        Dim dbl As Double
        If (colIndex = 1) Then
            CalcX = 0
            Exit Function
        End If
        
        Set rng1 = sh.Range("A1").Offset(0, colIndex - 2)
        Set rng2 = sh.Range(sh.Range("A1"), rng1)
        
        For Each r In rng2
            'X座標を計算
            'なぜか小数を切り上げた上で+1しないと一致しない
            dbl = dbl + Application.WorksheetFunction.RoundUp(r.Width, 0) + 1
        Next
        
        CalcX = dbl
    End Function
    


    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)
    2011年10月5日 11:01
  • gekkaさん御連絡ありがとうございます。

    私事ではありますが、親戚の法事などでこの回答を本日やっと見ることが出来ました。

    (バグ?)は想定していましたので、納得できました。対処方法については本日確認してみます。

    現在は強制的に台紙の方のレイアウトを変更して対処しております。全体的な処理スピードとの関係もありますので、お知らせ頂いた対処方法については、確認した結果で採用・不採用を決めたいと考えております。

    有難うございました。とりあえず御礼まで。

    2011年10月11日 2:41