vb problem in output to excel file

[maks]

Hi All;

i have a problem in vbs output to excel file,when i open the excel file and use the print preview function,the graphic box become large and change to orginal size.

 

 

' -- Start Script

Call Main()

 

 

' ////////////////////

' Sub Declaration

' ////////////////////

Sub Main()

' -- Add code here...

' -- Start ScriptCall Main()

' ////////////////////

' Sub Declaration

' ////////////////////

Dim intLevelNumber

Dim strMc

Dim strOriginalPath

Dim DataPoint

Dim Cpoint

Dim datax

Dim datay

Dim dataz

'-- Loop all levels, hide all except the one the user wants

'/////////// /

Dim lv_app

Dim lv_excel

Dim graphic

Dim lv_text

Dim Picture

 

Set lv_app = CreateObject("Excel.Application")

Set lv_excel = lv_app.workbooks.open ( "C:XYZ.XLS")

Dim i

Dim j : j = 1

Dim k : k = 16.5

 

For i = 1 To 100

If i <> intLevelNumber Then

Call SetLevelVisibleByNumber(i,True)

If IsDrawing() Then

SetLevelByNumber(i)

strOriginalPath = GetCurrentFileName()

'renname with LevelNumber

strMC= Replace(LCase(strOriginalPath), ".mc9", "-" & i & ".mc9")

Call RunMastercamCommand("fit")

'look for alive points

datapoint = StartDBSearch(mc_alive, mc_pointtype)

If (DataPoint = False) Then

ShowString "nil"

lv_excel.saveas( "C:XYZ.XLS")

CloseExcelFile

Exit Sub

End If

Set CPoint = New McPt

' -- Get this point x,y,z

If GetPointData(GetEntityEptr, cpoint) Then

'ShowString i

'get point data

datax=Round(cpoint.x,3)

datay=Round(cpoint.y,3)

dataz=Round(cpoint.z,3)

lv_excel.sheets(1).cells((j-1)*15+1,1) = datax

lv_excel.sheets(1).cells((j-1)*15+1,2) = datay

lv_excel.sheets(1).cells((j-1)*15+1,3) = dataz

j = j + 1

End If

strOriginalPath = GetCurrentFileName()

'renname with LevelNumber

graphic= Replace(LCase(strOriginalPath), ".mc9", "-" & i & ".emf")

Call RunMastercamCommand("fit")

' save emf file

DoMetafile graphic

'Height = 2000: Width = 1000

'Picture = LoadPicture(graphic)

' lv_excel.sheets(1).Shapes.AddPicture(Filename, LinktoFile, SavewithDocument, Left, Top, Width, Height)

Set lv_text = lv_excel.sheets(1)

lv_text.Shapes.AddPicture graphic, False , True , 0,k, 200, 160

k= k + 247.5

 

' save file

Call SaveMCAs(strmc,True)

Call SetLevelVisibleByNumber (i,False)

End If

End If

Next

Call RepaintScreen(True)

'End If

ShowString "complete"

lv_excel.saveas( "C:XYZ.XLS")

lv_excel.Close

lv_app.quit

Set lv_app = Nothing

End Sub

'entity serach

Function IsDrawing()

Dim Ret

Ret = StartDBSearch(mc_alive, -1)

IsDrawing = Ret

End Function

' ////////////////////

' Function Declaration

' ////////////////////

Public Sub ShowAllLevels

'-- Loop all levels and show them

Dim i

For i = 1 To 255

Call SetLevelVisibleByNumber(i,False)

Next

End Sub

 

 

thanks

Maks

[crazy^millman]

code:

---

 DoMetafile graphic

'Height = 2000: Width = 1000

---

I would look here may need to put control in here to allow the user to isze it to there needs. That Seems very big but since I can not test the code at home will have to wait till tommorrow if I go in to change out parts or for one of the VB kings like Rekd, Chris, Mick or others.

 

For our Excel set-up Sheets I use Clipboard. Do a search and There is a quick a easy script for doing Scren to white open up clipboard then change screen back to black again. rekd help me out with that one it is a real time saver.

 

HTH

[Bullines]

I've seen Excel have that problem with EMFs and it is quite weird. Excel appears not to like embedding resized EMF files into a spreadsheet. But BMPs seem to work ok. Try replacing this:

 

code:

---

'renname with LevelNumber 

graphic= Replace(LCase(strOriginalPath), ".mc9", "-" & i & ".emf")

---

with this:

 

code:

---

'renname with LevelNumber

graphic= Replace(LCase(strOriginalPath), ".mc9", "-" & i & ".bmp")

---

And replace this:

 

code:

---

' save emf file

DoMetafile graphic

---

with this:

 

code:

---

' save bmp file

Call DoBitmapfile(strOriginalPath, graphic)

---

Hope this helps.

[maks]

i will try it.

thanks