VBAを使用してExcelファイルをjpgにエクスポート

Question

私はB欄に画像を含むExcelファイルを持っており、それらを.jpg（または他の画像ファイル形式）としていくつかのファイルにエクスポートしたいと考えています。ファイルの名前は、私が試した列A内のテキストから生成されなければならないVBAマクロを次

Private Sub CommandButton1_Click() 
Dim oTxt As Object 
For Each cell In Ark1.Range("A1:A" & Ark1.UsedRange.Rows.Count) 
' you can change the sheet1 to your own choice 
saveText = cell.Text 
Open "H:\Webshop_Zpider\Strukturbildene\" & saveText & ".jpg" For Output As #1 
Print #1, cell.Offset(0, 1).text 
Close #1 
Next cell 
End Sub 

を結果は、それがどのコンテンツなしで、ファイル（JPG）を発生することです。私は線Print #1, cell.Offset(0, 1).text.が間違っていると仮定します。 私はそれを変更する必要があるか分からない、cell.Offset(0, 1).pix？

誰かが私を助けることができますか？ありがとう！

Answer 1

このコード：

Option Explicit 

Sub ExportMyPicture() 

    Dim MyChart As String, MyPicture As String 
    Dim PicWidth As Long, PicHeight As Long 

    Application.ScreenUpdating = False 
    On Error GoTo Finish 

    MyPicture = Selection.Name 
    With Selection 
      PicHeight = .ShapeRange.Height 
      PicWidth = .ShapeRange.Width 
    End With 

    Charts.Add 
    ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1" 
    Selection.Border.LineStyle = 0 
    MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2) 

    With ActiveSheet 
      With .Shapes(MyChart) 
       .Width = PicWidth 
       .Height = PicHeight 
      End With 

      .Shapes(MyPicture).Copy 

      With ActiveChart 
       .ChartArea.Select 
       .Paste 
      End With 

      .ChartObjects(1).Chart.Export Filename:="MyPic.jpg", FilterName:="jpg" 
      .Shapes(MyChart).Cut 
    End With 

    Application.ScreenUpdating = True 
    Exit Sub 

Finish: 
    MsgBox "You must select a picture" 
End Sub 

がhereから直接コピーされ、私がテストした場合のために、美しく機能しました。

Answer 2

正しく覚えていれば、シートの「図形」プロパティを使用する必要があります。

各Shapeオブジェクトには、画像の位置を示すTopLeftCellおよびBottomRightCell属性があります。

これは私がもう少し前に使ったコードです。あなたのニーズにおおよそ適応しています。ここで

For Each oShape In ActiveSheet.Shapes 
    strImageName = ActiveSheet.Cells(oShape.TopLeftCell.Row, 1).Value 
    oShape.Select 
    'Picture format initialization 
    Selection.ShapeRange.PictureFormat.Contrast = 0.5: Selection.ShapeRange.PictureFormat.Brightness = 0.5: Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic: Selection.ShapeRange.PictureFormat.TransparentBackground = msoFalse: Selection.ShapeRange.Fill.Visible = msoFalse: Selection.ShapeRange.Line.Visible = msoFalse: Selection.ShapeRange.Rotation = 0#: Selection.ShapeRange.PictureFormat.CropLeft = 0#: Selection.ShapeRange.PictureFormat.CropRight = 0#: Selection.ShapeRange.PictureFormat.CropTop = 0#: Selection.ShapeRange.PictureFormat.CropBottom = 0#: Selection.ShapeRange.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft: Selection.ShapeRange.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft 
    '/Picture format initialization 
    Application.Selection.CopyPicture 
    Set oDia = ActiveSheet.ChartObjects.Add(0, 0, oShape.Width, oShape.Height) 
    Set oChartArea = oDia.Chart 
    oDia.Activate 
    With oChartArea 
     .ChartArea.Select 
     .Paste 
     .Export ("H:\Webshop_Zpider\Strukturbildene\" & strImageName & ".jpg") 
    End With 
    oDia.Delete 'oChartArea.Delete 
Next 

Answer 3

（この場合はIrfanViewは）コマンドラインスイッチを受け付け外部ビューアエン使ってIT-行う別のクールな方法である：私はこれらすべてのChartObjectsやその他もろもろについての詳細を覚えていないが、ここでは、 ： *私はMichal Krzychが上に書いたものに基づいてループを作りました。

Sub ExportPicturesToFiles() 
    Const saveSceenshotTo As String = "C:\temp\" 
    Const pictureFormat As String = ".jpg" 

    Dim pic As Shape 
    Dim sFileName As String 
    Dim i As Long 

    i = 1 

    For Each pic In ActiveSheet.Shapes 
     pic.Copy 
     sFileName = saveSceenshotTo & Range("A" & i).Text & pictureFormat 

     Call ExportPicWithIfran(sFileName) 

     i = i + 1 
    Next 
End Sub 

Public Sub ExportPicWithIfran(sSaveAsPath As String) 
    Const sIfranPath As String = "C:\Program Files\IrfanView\i_view32.exe" 
    Dim sRunIfran As String 

    sRunIfran = sIfranPath & " /clippaste /convert=" & _ 
          sSaveAsPath & " /killmesoftly" 

    ' Shell is no good here. If you have more than 1 pic, it will 
    ' mess things up (pics will over run other pics, becuase Shell does 
    ' not make vba wait for the script to finish). 
    ' Shell sRunIfran, vbHide 

    ' Correct way (it will now wait for the batch to finish): 
    call MyShell(sRunIfran) 
End Sub 

編集：必要に応じて最小限にコードをスリム

Private Sub MyShell(strShell As String) 
    ' based on: 
    ' http://stackoverflow.com/questions/15951837/excel-vba-wait-for-shell-command-to-complete 
    ' by Nate Hekman 

    Dim wsh As Object 
    Dim waitOnReturn As Boolean: 
    Dim windowStyle As VbAppWinStyle 

    Set wsh = VBA.CreateObject("WScript.Shell") 
    waitOnReturn = True 
    windowStyle = vbHide 

    wsh.Run strShell, windowStyle, waitOnReturn 
End Sub 

Answer 4

Dim filepath as string 
Sheets("Sheet 1").ChartObjects("Chart 1").Chart.Export filepath & "Name.jpg" 

。

Answer 5

''」フォルダに

ワークブック（ "ワークブック名​​"）をエクスポートする範囲を設定します。シート（ "yoursheet名"）。あなたが使用することができ

Dim rgExp As Range: Set rgExp = Range("A1:H31") 
''' Copy range as picture onto Clipboard 
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap 
''' Create an empty chart with exact size of range copied 
With ActiveSheet.ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _ 
Width:=rgExp.Width, Height:=rgExp.Height) 
.Name = "ChartVolumeMetricsDevEXPORT" 
.Activate 
End With 
''' Paste into chart area, export to file, delete chart. 
ActiveChart.Paste 
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Chart.Export "C:\ExportmyChart.jpg" 
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Delete