S
Sachin
Hi,
I am trying to insert the picture from MSchart into excel but i am not
able to paste the image into excel.
This is the code which i have tried :
_______________________________________________________________
Private Sub Command2_Click()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Dim r,c,rv As Long
Dim Filename As String, objRange As Range
Dim SuggestedName,cmbCaseVar, cmbCaseVarSave As String
Dim MSG, Style, Response
Dim rtemp,CountVar As Integer
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Add
Set xlWS = xlWB.Worksheets("Sheet1")
xlApp.Visible = False
xlApp.UserControl = False
cmbCaseVar = cmbCase.Text
cmbCaseVarSave = cmbCase.Text
SuggestedName = "Test"
Filename = xlApp.GetSaveAsFilename("C:\" & SuggestedName & ".xls", _
"WorkBook (*.xls), *.xls", , "Select or enter a File Name:")
If Filename = "False" Then Exit Sub
If (Len(Dir$(Filename)) > 0) Then
Style = vbYesNo + vbExclamation
MSG = "The file already exists," & vbCrLf & _
"would you like to overwrite it?"
Response = MsgBox(MSG, Style)
If Response = vbNo Then
GoTo Cleanup
End If
End If
On Error GoTo ErrorHandler
Open Filename For Binary Access _
Read Write Lock Read Write As #1
Close #1
On Error GoTo 0
On Error Resume Next
For r = 0 To MSFlexGrid1.Rows - 1
For c = 0 To MSFlexGrid1.Cols - 1
xlWS.Cells(r + 1, c) = MSFlexGrid1.TextMatrix(r, c)
Next
Next
xlWS.Cells.Columns.AutoFit
xlWS.PageSetup.PrintHeadings = True
'First Method
With xlWS.Range("A75")
Set Picture1 = .Parent.Pictures.Insert(Picture1.Picture)
End With
'Second MEthod
With Picture1
.Height = MSChart1.Height
.Width = MSChart1.Width
End With
Picture1.AutoRedraw = True
rv = SendMessage(MSChart1.hWnd, WM_PAINT, Picture1.hDC, 0)
Picture1.Picture = Picture1.Image
Picture1.AutoRedraw = False
Clipboard.Clear
Clipboard.SetData Picture1.Picture
InsertPictureInRange Picture1.Picture, xlWS.Range("A75:F95").Select
xlApp.DisplayAlerts = False 'overwrite existing file without prompt
xlWB.SaveAs Filename
Cleanup:
Call xlWB.Close(SaveChanges:=False)
xlApp.DisplayAlerts = True
xlApp.Quit
Set xlWB = Nothing
Set xlWS = Nothing
Set xlApp = Nothing
Exit Sub
ErrorHandler:
MsgBox "E R R O R - The file that your are trying to
access," _
& vbCrLf & "is already open." & vbCrLf & vbCrLf & _
"Please close the file and try again", vbCritical
GoTo Cleanup
End Sub
Private Sub InsertPictureInRange(PictureFile As PictureBox,
TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
Set p = ActiveSheet.Pictures.Insert(PictureFile.Picture)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub
________________________________________________
thanks in advance.
Sachin
I am trying to insert the picture from MSchart into excel but i am not
able to paste the image into excel.
This is the code which i have tried :
_______________________________________________________________
Private Sub Command2_Click()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Dim r,c,rv As Long
Dim Filename As String, objRange As Range
Dim SuggestedName,cmbCaseVar, cmbCaseVarSave As String
Dim MSG, Style, Response
Dim rtemp,CountVar As Integer
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Add
Set xlWS = xlWB.Worksheets("Sheet1")
xlApp.Visible = False
xlApp.UserControl = False
cmbCaseVar = cmbCase.Text
cmbCaseVarSave = cmbCase.Text
SuggestedName = "Test"
Filename = xlApp.GetSaveAsFilename("C:\" & SuggestedName & ".xls", _
"WorkBook (*.xls), *.xls", , "Select or enter a File Name:")
If Filename = "False" Then Exit Sub
If (Len(Dir$(Filename)) > 0) Then
Style = vbYesNo + vbExclamation
MSG = "The file already exists," & vbCrLf & _
"would you like to overwrite it?"
Response = MsgBox(MSG, Style)
If Response = vbNo Then
GoTo Cleanup
End If
End If
On Error GoTo ErrorHandler
Open Filename For Binary Access _
Read Write Lock Read Write As #1
Close #1
On Error GoTo 0
On Error Resume Next
For r = 0 To MSFlexGrid1.Rows - 1
For c = 0 To MSFlexGrid1.Cols - 1
xlWS.Cells(r + 1, c) = MSFlexGrid1.TextMatrix(r, c)
Next
Next
xlWS.Cells.Columns.AutoFit
xlWS.PageSetup.PrintHeadings = True
'First Method
With xlWS.Range("A75")
Set Picture1 = .Parent.Pictures.Insert(Picture1.Picture)
End With
'Second MEthod
With Picture1
.Height = MSChart1.Height
.Width = MSChart1.Width
End With
Picture1.AutoRedraw = True
rv = SendMessage(MSChart1.hWnd, WM_PAINT, Picture1.hDC, 0)
Picture1.Picture = Picture1.Image
Picture1.AutoRedraw = False
Clipboard.Clear
Clipboard.SetData Picture1.Picture
InsertPictureInRange Picture1.Picture, xlWS.Range("A75:F95").Select
xlApp.DisplayAlerts = False 'overwrite existing file without prompt
xlWB.SaveAs Filename
Cleanup:
Call xlWB.Close(SaveChanges:=False)
xlApp.DisplayAlerts = True
xlApp.Quit
Set xlWB = Nothing
Set xlWS = Nothing
Set xlApp = Nothing
Exit Sub
ErrorHandler:
MsgBox "E R R O R - The file that your are trying to
access," _
& vbCrLf & "is already open." & vbCrLf & vbCrLf & _
"Please close the file and try again", vbCritical
GoTo Cleanup
End Sub
Private Sub InsertPictureInRange(PictureFile As PictureBox,
TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
Set p = ActiveSheet.Pictures.Insert(PictureFile.Picture)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub
________________________________________________
thanks in advance.
Sachin