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", so the picture is never the same. You can see it when you run it in the IDE and not with .exe.

I found it. Now it's working using this: "C:\Pic" & gridRow & ".bmp"

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

        For gridRow = 1 To MSHFlexGrid1.Rows - 1
            If MSHFlexGrid1.TextMatrix(gridRow, 1) <> "" Then
  
                For xlRow = 2 To (MSHFlexGrid1.Rows - 1) + 1
                    If xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 2) = "" Then

                        Form1.Text1.Text = MSHFlexGrid1.TextMatrix(gridRow, 1)
                        makeBC
                        
                        DoEvents

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

                       ' Sleep 200 ' to sleep for 1 second

                        xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).AddComment.Shape.Fill.UserPicture "C:\Pic" & gridRow & ".bmp"
                        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 = 200
                        xlObj.ActiveWorkbook.ActiveSheet.Rows(xlRow).RowHeight = 61
                        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) = Text1.Text
                        xlRow = xlRow + 1

                    End If
                Next xlRow
            End If
        Next gridRow
    End With

Select all Open in new window

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?

i didn't want to create a tone of images. sometime, i can create up to 200.

I still need to look at it. still doesn't work with: "C:\Pic" & gridRow & ".bmp"

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

even after the save, i still get the same problem.
   '********************************************************************************************************
                        SavePicture Picture1.Image, "C:\Pic.bmp"
 '********************************************************************************************************

I just tried bellow without success:

                        '********************************************************************************************************
                        SavePicture Picture1.Image, "C:\Pic_" & MSHFlexGrid1.Row & ".bmp"
                        '********************************************************************************************************

DoEvents

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

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?

Jan, what makes the Picture1 change is:

makeBC

Select all Open in new window

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?

The barcode get generated everytime a number is populated in Text1. So it loops every numbers (one by one) from the grid by putting each number in Text1 and save the picture to use it in the Excel file. Then it goes to the next number from the grid...

You can test the barcode manually if you type directly in Text1. You will see the barcode being generated.

To understand how the barcode and Picture1 gets generated based on Text1, see below code:

Private Sub makei25()
Dim x As Long, y As Long, pos As Long
Dim Bardata As String
Dim Cur As String
Dim temp As String
Dim chksum As Long
Dim BC(11) As String
    '2 of the 5 elements are wide: 0=narrow, 1=wide
    BC(0) = "00110" '0
    BC(1) = "10001" '1
    BC(2) = "01001" '2
    BC(3) = "11000" '3
    BC(4) = "00101" '4
    BC(5) = "10100" '5
    BC(6) = "01100" '6
    BC(7) = "00011" '7
    BC(8) = "10010" '8
    BC(9) = "01010" '9
    BC(10) = "0000" 'Start chr
    BC(11) = "100" 'Stop chr
    
    Picture1.Cls
    If Text1.Text = "" Then Exit Sub
    pos = 20
    Bardata = Text1.Text
    
    'make even num of digits by adding a leading 0
    If Len(Bardata) Mod 2 And Not Check1(2).Value Then Bardata = "0" & Bardata
    If Not (Len(Bardata) Mod 2) And Check1(2).Value Then Bardata = "0" & Bardata
    
    'Check for invalid characters and calculate check sum
    For x = 1 To Len(Bardata)
        Cur = Mid$(Bardata, x, 1)
        If Cur < "0" Or Cur > "9" Then
            Picture1.Print Cur & " is Invalid"
            Exit Sub
        End If
        'make checksum
        If x Mod 2 Then
            chksum = chksum + CLng(Cur) * 3
        Else
            chksum = chksum + CLng(Cur)
        End If
    Next
    
    'add check chr to bardata (if selected)
    If Check1(2).Value Then
        chksum = (10 - chksum Mod 10) Mod 10
        Bardata = Bardata & Chr$(48 + chksum)
    End If
    
    'interleave the code into a temp string - what'd you think the name meant?
    For x = 1 To Len(Bardata) Step 2
        For y = 1 To 5
            temp = temp & Mid$(BC(Val(Mid$(Bardata, x, 1))), y, 1)
            temp = temp & Mid$(BC(Val(Mid$(Bardata, x + 1, 1))), y, 1)
        Next
    Next
    
    'add Start & Stop characters
    temp = BC(10) & temp & BC(11)
    
    'Generate Barcode
    For x = 1 To Len(temp)
        If x Mod 2 = 0 Then
                'SPACE
                pos = pos + 1 + (2 * Val(Mid$(temp, x, 1))) + Check1(0).Value
        Else
                'BAR
                For y = 1 To 1 + (2 * Val(Mid$(temp, x, 1)))
                    Picture1.Line (pos, 1)-(pos, 58 - Check1(1) * 8)
                    pos = pos + 1
                Next
        End If
    Next

    'Add Label?
    If Check1(1).Value Then
        Picture1.CurrentX = 20 + Len(Bardata) * (2 + Check1(0).Value * 1.3) 'kinda center
        Picture1.CurrentY = 50
        Picture1.Print Bardata;
    End If
End Sub

Select all Open in new window

i see that for some reasons, when using .exe, it doesn't save to "C:\Pic" & gridRow & ".bmp" while using IDE, it does save to "C:\Pic" & gridRow & ".bmp".

That's kind of strange.

I'm now seeing the file in "C:\Pic" & gridRow & ".bmp"

But still not uploading in excel file using the .exe

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.

Martin, I just tried to put the DoEvents directly after the code that uploads the excel file but still having the same issue.

I'm getting at the point that this will never work. Oh well!!!

I will look at the Application see if this can be an option for me. It may be the best solution at the end.

Please re-upload your project including recent changes.

This is the most updated project sample. You will see that using IDE it works bit not when using exe.

I'm also looking at the app you talked about. Will see if this can be a solution. So far, it looks good.
BareCode-1-no3.zip

I don't remember what i did before i sent you the last sample but it looks like it's working now. I will take a pause and will test it again in about an hour, just to make sure i'm not mistaken here.

I'm getting confused right now.

Status?

After some extra test this afternoon, I still have the same problem with exe, unfortunately.

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.

ok, let me try something. I'm under Windows 10 and office 365. I will test with another version on another computer. Just in case.

Thanks for the test that you did. Now i know that it really works.

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

Well well well!!!!!

Windows 10 and Excel 2013 on another laptop and the result with .exe is good.

I just tried with 4 values in MSHFlexgrid1 and it only does the 2 first numbers but in duplicates instead of 4 different numbers. Can you try it on your side please?

I just update this code below:

Private Sub Form_Resize()
 '   Picture1.Width = Form1.Width - 360
 '   makeBC
    
    MSHFlexGrid1.TextMatrix(1, 1) = "1234567"
    MSHFlexGrid1.TextMatrix(2, 1) = "987654"
     MSHFlexGrid1.TextMatrix(3, 1) = "95623"
    MSHFlexGrid1.TextMatrix(4, 1) = "77845"
    MSHFlexGrid1.TextMatrix(0, 0) = "BARCODE VALUE"
    MSHFlexGrid1.TextMatrix(0, 1) = "BARCODE VALUE"
    MSHFlexGrid1.TextMatrix(0, 2) = "BARCODE VALUE"
    
     'Auto column fit
    Dim cell_wid As Single
    Dim col_wid As Single
    Dim C As Long
    Dim r As Long '

    For C = 0 To MSHFlexGrid1.Cols - 1
        col_wid = 0
        For r = 0 To MSHFlexGrid1.Rows - 1
            cell_wid = TextWidth(MSHFlexGrid1.TextMatrix(r, C))
            If col_wid < cell_wid Then col_wid = cell_wid
        Next r
        MSHFlexGrid1.ColWidth(C) = col_wid + 120
    Next C
 '   cmdCommand2.Value = True
End Sub

Select all Open in new window

Can you supply the msflexgrid that has the 4 barcodes/

This is the one with 4 numbers but it does only the 2 first numbers in duplicates under windows 10 Excel 2013

Barcode-3-no4.zip

Thanks again for all your help. I just tried with over 500 numbers and it's all working now. That topic as been a long ride.

Martin, i like the app for Excel. I will see if i can also do something in Excel directly and use the app. I just tested the trial version. Very good.

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

Thanks a lot for all the above recommendations and code updates. Really appreciated.  I will follow them for sure. Will work on it and i will let you know if i have any questions.