VB6 - DoEvents problem while extracting to Excel

you got the same barcode image because you made it static in your code:

xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).AddComment.Shape.Fill.UserPicture "C:\Pic.bmp"

you need to retrieve the correct image path before you insert that image into the Excel.

That image get's overwritten in a loop :"C:\Pic.bmp"

why you want to overwritten it? why don't you saved as a series of images?

if you insist to use Pic.bmp as the only output, you probably can put the DoEvents statement after the SavePicture .

like:

                        '********************************************************************************************************
                        SavePicture Picture1.Image, "C:\Pic.bmp"
                        '********************************************************************************************************
DoEvents

Select all Open in new window

ooops, I missed out an important part!

before:

SavePicture Picture1.Image, "C:\Pic" & gridRow & ".bmp"

you need to reload image to Picture1.

Think you need to add LoadPicture method to reload image before you save the picture...

You are taking the picture from a control called Picture1, but I don't see any code that actually changes the image of Picture1 in the loop which populates Excel?

can you tell where's the image source that loaded into Picture1 ?

why don't you just use it directly in:

xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).AddComment.Shape.Fill.UserPicture "C:\Pic" & gridRow & ".bmp"

Select all Open in new window

instead of load it into a PictureBox, and then Save it to a location and use that file for your process?

Have you tried adding a DoEvents directly after the code that uploads the excel file?

Have you considered doing the whole process in Excel? If you are concerned about making an Excel workbook into an exe this app can apparently do that.

Please re-upload your project including recent changes.

Status?

Well I have good news/bad news. Using this code, which I don't think I modified, I get 2 different barcodes via the exe.

Private Sub Command6_Click()
'***************************************************************************************************
'xlObj.ActiveWorkbook.ActiveSheet.Range("A1") = "BARCODE"
'xlObj.ActiveWorkbook.ActiveSheet.Range("A3").AddComment.Shape.Fill.UserPicture "C:\Pic.bmp"
'xlObj.ActiveWorkbook.ActiveSheet.Range("A3").Comment.Text " "
'xlObj.ActiveWorkbook.ActiveSheet.Range("A3").Comment.Height = 660
'xlObj.ActiveWorkbook.ActiveSheet.Range("A3").Comment.Shape.Width = 680
'xlObj.ActiveWorkbook.ActiveSheet.Rows("3:3").RowHeight = 62
'xlObj.ActiveWorkbook.ActiveSheet.Columns("A").ColumnWidth = 129.43
'xlObj.ActiveWorkbook.ActiveSheet.Range("A3").Comment.Visible = True
'xlObj.ActiveWorkbook.ActiveSheet.Range("A3").Comment.Shape.Top = xlObj.ActiveWorkbook.ActiveSheet.Range("A3").Top
'xlObj.ActiveWorkbook.ActiveSheet.Range("A3").Comment.Shape.Left = xlObj.ActiveWorkbook.ActiveSheet.Range("A3").Left
'xlObj.ActiveWorkbook.ActiveSheet.Range("A3").Comment.Shape.Placement = 1

'xlObj.ActiveWorkbook.ActiveSheet.Range("B1") = "BARCODE VALUE"
'xlObj.ActiveWorkbook.ActiveSheet.Range("B3") = MSHFlexGrid1.TextMatrix(r, 1)

'***************************************************************************************************



    Dim xlObj As Object    'New Excel.Application -- only used with Excel reference
    Dim wkbOut As Object   'Excel.Workbook
    Dim wksOut As Object   'Excel.Worksheet
    Dim rngOut As Object   'Excel.Range
    Dim sngStart As Single    'forperformance measurement
    Dim start_time As Long
    Dim end_time As Long
    Dim total_time As Long
    Dim FileNm As Variant

    On Error Resume Next

    'Save file to
    With CommonDialog2
        .DialogTitle = "BarCode extract..."
        .FileName = Label3.Caption
        .CancelError = True  '<--moved
        .Filter = "Spreadsheet Files (*.xls)|*.xls| 2k7 Excel Files (*.xlsx)|*.xlsx"
        .ShowSave


        If Err.Number = 32755 Then
            MsgBox "not saved - user pressed cancel or closed the dialog"
            Exit Sub
        Else
            FileNm = .FileName
            path_link = FileNm & ".xls"
        End If

    End With
    'output to Excel workbook
    Set xlObj = CreateObject("Excel.Application")
    Set wkbOut = xlObj.Workbooks.Add
    Set wksOut = wkbOut.Worksheets("Sheet1")  'can skip this step
    Set rngOut = wksOut.range("A1")           'by replacing with wkbOut.Worksheets("Sheet1").Range("A1")

    Me.MousePointer = vbHourglass
    Me.Enabled = False

    xlObj.ScreenUpdating = False
    xlObj.Calculation = -4135     '=xlCalculationManual

    ' sngStart = Timer1
    start_time = Format(Now, "ss")


    '***************************************************************     MSHFlexGrid1 copy to excel

    Set wksOut = xlObj.ActiveWorkbook.Worksheets.Add
    wksOut.Name = "Extract_data"
    xlObj.ActiveWorkbook.ActiveSheet.range("A1") = "BARCODE"
    xlObj.ActiveWorkbook.ActiveSheet.range("B1") = "BARCODE VALUE"
    xlObj.ActiveWorkbook.ActiveSheet.Columns("A").ColumnWidth = 43.39


     With MSHFlexGrid1
        Dim gridRow As Long, xlRow As Long
        Dim LastRow As Long


        For gridRow = 1 To MSHFlexGrid1.Rows - 1
            If MSHFlexGrid1.TextMatrix(gridRow, 1) <> "" Then
            
              Text1.Text = MSHFlexGrid1.TextMatrix(gridRow, 1)
                        
                        
                LastRow = xlObj.ActiveWorkbook.ActiveSheet.range("B1", xlObj.ActiveWorkbook.ActiveSheet.range("B1").End(xlDown)).Rows.Count
                For xlRow = 2 To (MSHFlexGrid1.Rows - 1) + 1
                     makeBC
                        '********************************************************************************************************
                        SavePicture Picture1.Image, "C:\Pic_" & gridRow & ".jpg"
                        '********************************************************************************************************
 
            
                    If xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 2) = "" Then

 'Sleep 4000 ' to sleep for 1 second

                        xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).AddComment.Shape.Fill.UserPicture "C:\Pic_" & gridRow & ".jpg"

                        xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).Comment.Text " "
                        xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).Comment.Height = 660
                        xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).Comment.Shape.Width = 230.38
                        xlObj.ActiveWorkbook.ActiveSheet.Rows(xlRow).RowHeight = 62
                        xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).Comment.Visible = True
                        xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).Comment.Shape.Top = xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).Top
                        xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).Comment.Shape.Left = xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).Left
                        xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).Comment.Shape.Placement = 1

                        xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 2) = Form1.MSHFlexGrid1.TextMatrix(gridRow, 1)
                        xlRow = xlRow + 1

                    End If
                Next xlRow
            End If
        Next gridRow

    End With


    With xlObj.ActiveWorkbook.ActiveSheet


        On Error Resume Next
        .range("A1").Select
        .range("A1:z1").Interior.Color = RGB(205, 197, 191)
        .Columns("A:z").NumberFormat = "@"
        .Columns("B:B").ColumnWidth = 23
        .range("$A:$B").AutoFilter
    End With

DoEvents

    xlObj.ActiveWorkbook.SaveAs FileNm

    xlObj.Calculation = -4105     '=xlCalculationAutomatic
    xlObj.ScreenUpdating = True
   ' xlObj.Visible = True
    xlObj.DisplayAlerts = False
    xlObj.Close
    xlObj.Quit
    xlObj.Save = True

    Set rngOut = Nothing
    Set wksOut = Nothing
    Set wkbOut = Nothing
    Set xlObj = Nothing
    
    

    Me.MousePointer = vbDefault
    Me.Enabled = True
    
    MsgBox "Extract completed"

End Sub

Select all Open in new window

Here's what it looked like. Note that I used an xlsx file. I'll try it with and xls file and see if that makes a difference.

No  difference with an xls, but Excel 2010 warned me that the file format didn't agree with the extension.

I'm Windows XP:) Old dog...

Can you supply the msflexgrid that has the 4 barcodes/

I changed a few things.
You were referring to xlObj.ActiveWorkbook which would cause a problem if the probably rare circumstance where the user opened or selected another workbook while the barcode processing was going on so I changed it to wkbOut.ActiveSheet.

I changed the name of the workbook from what was in Label3.Caption to "Barcodes" which you can of course change. Label3 isn't used so the name of the workbook became "Label3".

I deleted the reference to path_link because it wasn't used or defined. (How did the project compile?)

I changed .ShowSave to .ShowOpen in the CommonDialog2 code so that the button says "Open" rather than "Save" which was confusing.

I suggest you add CommonDialog processing at the end when you close the workbook because as it is now the workbook gets saved no matter if you press Yes, No or Cancel in response to SaveAs.

I also suggest you get rid of all the dead command buttons (Command1 through Command5) and their code.

Private Sub Command6_Click()
Dim xlObj As Object    'New Excel.Application -- only used with Excel reference
    Dim wkbOut As Object   'Excel.Workbook
    Dim wksOut As Object   'Excel.Worksheet
    Dim rngOut As Object   'Excel.Range
    Dim sngStart As Single    'forperformance measurement
    Dim start_time As Long
    Dim end_time As Long
    Dim total_time As Long
    Dim FileNm As Variant
    Dim gridRow As Long


    On Error Resume Next

    'Save file to
    With CommonDialog2
        .DialogTitle = "BarCode extract..."
        .FileName = "Barcodes" 'Label3.Caption
        .CancelError = True  '<--moved
        .Filter = "Spreadsheet Files (*.xls)|*.xls| 2k7 Excel Files (*.xlsx)|*.xlsx"
        .ShowOpen '.ShowSave


        If Err.Number = 32755 Then
            MsgBox "not saved - user pressed cancel or closed the dialog"
            Exit Sub
        Else
            FileNm = .FileName
            'path_link = FileNm & ".xls"
        End If

    End With
    'output to Excel workbook
    Set xlObj = CreateObject("Excel.Application")
    Set wkbOut = xlObj.Workbooks.Add
    Set wksOut = wkbOut.Worksheets("Sheet1")  'can skip this step
    Set rngOut = wksOut.range("A1")           'by replacing with wkbOut.Worksheets("Sheet1").Range("A1")

    Me.MousePointer = vbHourglass
    Me.Enabled = False

    xlObj.ScreenUpdating = False
    xlObj.Calculation = -4135     '=xlCalculationManual

    ' sngStart = Timer1
    start_time = Format(Now, "ss")


    '***************************************************************     MSHFlexGrid1 copy to excel

    Set wksOut = xlObj.ActiveWorkbook.Worksheets.Add
    wksOut.Name = "Extract_data"
    wkbOut.ActiveSheet.range("A1") = "BARCODE"
    wkbOut.ActiveSheet.range("B1") = "BARCODE VALUE"
    wkbOut.ActiveSheet.Columns("A").ColumnWidth = 43.39


     With MSHFlexGrid1
        For gridRow = 1 To MSHFlexGrid1.Rows - 1
            If MSHFlexGrid1.TextMatrix(gridRow, 1) <> "" Then
            
              Text1.Text = MSHFlexGrid1.TextMatrix(gridRow, 1)
                    makeBC
                    '********************************************************************************************************
                    SavePicture Picture1.Image, "C:\Pic_" & gridRow & ".jpg"
                    '********************************************************************************************************
                   If wkbOut.ActiveSheet.Cells(gridRow + 1, 2) = "" Then
                       wkbOut.ActiveSheet.Cells(gridRow + 1, 1).AddComment.Shape.Fill.UserPicture "C:\Pic_" & gridRow & ".jpg"
                       wkbOut.ActiveSheet.Cells(gridRow + 1, 1).Comment.Text " "
                       wkbOut.ActiveSheet.Cells(gridRow + 1, 1).Comment.Height = 660
                       wkbOut.ActiveSheet.Cells(gridRow + 1, 1).Comment.Shape.Width = 230.38
                       wkbOut.ActiveSheet.Rows(gridRow + 1).RowHeight = 62
                       wkbOut.ActiveSheet.Cells(gridRow + 1, 1).Comment.Visible = True
                       wkbOut.ActiveSheet.Cells(gridRow + 1, 1).Comment.Shape.Top = wkbOut.ActiveSheet.Cells(gridRow + 1, 1).Top
                       wkbOut.ActiveSheet.Cells(gridRow + 1, 1).Comment.Shape.Left = wkbOut.ActiveSheet.Cells(gridRow + 1, 1).Left
                       wkbOut.ActiveSheet.Cells(gridRow + 1, 1).Comment.Shape.Placement = 1

                       wkbOut.ActiveSheet.Cells(gridRow + 1, 2) = Form1.MSHFlexGrid1.TextMatrix(gridRow, 1)
                   End If
            End If
        Next gridRow

    End With


    With wkbOut.ActiveSheet


        On Error Resume Next
        .range("A1").Select
        .range("A1:z1").Interior.Color = RGB(205, 197, 191)
        .Columns("A:z").NumberFormat = "@"
        .Columns("B:B").ColumnWidth = 23
        .range("$A:$B").AutoFilter
    End With

DoEvents

    wkbOut.SaveAs FileNm

    xlObj.Calculation = -4105     '=xlCalculationAutomatic
    xlObj.ScreenUpdating = True
    xlObj.Visible = True
    xlObj.DisplayAlerts = False
  '  xlObj.Close
  '  xlObj.Quit
  '  xlObj.Save = True

    Set rngOut = Nothing
    Set wksOut = Nothing
    Set wkbOut = Nothing
    Set xlObj = Nothing
    
    

    Me.MousePointer = vbDefault
    Me.Enabled = True
    
    MsgBox "Extract completed"
End Sub

Select all Open in new window