VB6 - DoEvents problem while extracting to Excel

Wilder1626
Wilder1626 used Ask the Experts™
on
Hi

I have this below code that generates BarCodes based on values from my MSHFlexgrid1 while the picture is in a PictureBox ("Picture1")

 when run in the IDE, I have each Picture related to the Value from my MSHFlexgrid1.
Ex:
No issue
When i run it with the .exe, this is when i have the problem where the pictures don't match.
Ex:
with issue
The code i have is:
  xlObj.ActiveWorkbook.ActiveSheet.range("A1") = "BARCODE"
    xlObj.ActiveWorkbook.ActiveSheet.range("B1") = "BARCODE VALUE"
    xlObj.ActiveWorkbook.ActiveSheet.Columns("A").ColumnWidth = 37.59


     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.bmp"
                        '********************************************************************************************************

                       ' Sleep 200 ' to sleep for 1 second

                        xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).AddComment.Shape.Fill.UserPicture "C:\Pic.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

Open in new window


I did try "DoEvents' at multiple places but still having the same problem.

How can i fix this?

Thank you for your help.
Extract-to-Excel-issue-no1.zip
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
View Solution Only
Ryan ChongSoftware Team Lead

Commented:
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.
Wilder1626

Author

Commented:
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.
Wilder1626

Author

Commented:
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

Open in new window

Ensure you’re charging the right price for your IT

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

Find out now!
Ryan ChongSoftware Team Lead

Commented:
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?
Wilder1626

Author

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

Author

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

Commented:
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

Open in new window

Wilder1626

Author

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

Author

Commented:
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"

Open in new window

Ryan ChongSoftware Team Lead

Commented:
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...
Jan Karel PieterseExcel and VBA Expert

Commented:
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?
Wilder1626

Author

Commented:
Jan, what makes the Picture1 change is: 
makeBC

Open in new window

Ryan ChongSoftware Team Lead

Commented:
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"

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?
Wilder1626

Author

Commented:
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.
barcode 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

Open in new window

Wilder1626

Author

Commented:
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.
Wilder1626

Author

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

But still not uploading in excel file using the .exe
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Commented:
Have you tried adding a DoEvents directly after the code that uploads the excel file?
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Commented:
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.
Wilder1626

Author

Commented:
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.
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Commented:
Please re-upload your project including recent changes.
Wilder1626

Author

Commented:
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
Wilder1626

Author

Commented:
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.
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Commented:
Status?
Wilder1626

Author

Commented:
After some extra test this afternoon, I still have the same problem with exe, unfortunately.
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Commented:
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

Open in new window

Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Commented:
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.
2018-10-10_16-29-27.jpg
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

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

Author

Commented:
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.
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

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

Author

Commented:
Well well well!!!!!

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

Result
Wilder1626

Author

Commented:
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

Open in new window

Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Commented:
Can you supply the msflexgrid that has the 4 barcodes/
Wilder1626

Author

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

diplicateBarcode-3-no4.zip
Older than dirt
Most Valuable Expert 2017
Distinguished Expert 2018
Commented:
Try this. The second loop (for the workbook) was unnecessary and messing things up.

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

    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)
                    makeBC
                    '********************************************************************************************************
                    SavePicture Picture1.Image, "C:\Pic_" & gridRow & ".jpg"
                    '********************************************************************************************************
                   If xlObj.ActiveWorkbook.ActiveSheet.Cells(gridRow + 1, 2) = "" Then
                       xlObj.ActiveWorkbook.ActiveSheet.Cells(gridRow + 1, 1).AddComment.Shape.Fill.UserPicture "C:\Pic_" & gridRow & ".jpg"
                       xlObj.ActiveWorkbook.ActiveSheet.Cells(gridRow + 1, 1).Comment.Text " "
                       xlObj.ActiveWorkbook.ActiveSheet.Cells(gridRow + 1, 1).Comment.Height = 660
                       xlObj.ActiveWorkbook.ActiveSheet.Cells(gridRow + 1, 1).Comment.Shape.Width = 230.38
                       xlObj.ActiveWorkbook.ActiveSheet.Rows(gridRow + 1).RowHeight = 62
                       xlObj.ActiveWorkbook.ActiveSheet.Cells(gridRow + 1, 1).Comment.Visible = True
                       xlObj.ActiveWorkbook.ActiveSheet.Cells(gridRow + 1, 1).Comment.Shape.Top = xlObj.ActiveWorkbook.ActiveSheet.Cells(gridRow + 1, 1).Top
                       xlObj.ActiveWorkbook.ActiveSheet.Cells(gridRow + 1, 1).Comment.Shape.Left = xlObj.ActiveWorkbook.ActiveSheet.Cells(gridRow + 1, 1).Left
                       xlObj.ActiveWorkbook.ActiveSheet.Cells(gridRow + 1, 1).Comment.Shape.Placement = 1

                       xlObj.ActiveWorkbook.ActiveSheet.Cells(gridRow + 1, 2) = Form1.MSHFlexGrid1.TextMatrix(gridRow, 1)
                   End If
            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

Open in new window

Wilder1626

Author

Commented:
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.
Martin LissOlder than dirt
Most Valuable Expert 2017
Distinguished Expert 2018

Commented:
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

Open in new window

Wilder1626

Author

Commented:
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.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial