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
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
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?
'********************************************************************************************************
SavePicture Picture1.Image, "C:\Pic.bmp"
'********************************************************************************************************
DoEvents
'********************************************************************************************************
SavePicture Picture1.Image, "C:\Pic_" & MSHFlexGrid1.Row & ".bmp"
'********************************************************************************************************
DoEvents
xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).AddComment.Shape.Fill.UserPicture "C:\Pic_" & MSHFlexGrid1.Row & ".bmp"
makeBC
xlObj.ActiveWorkbook.ActiveSheet.Cells(xlRow, 1).AddComment.Shape.Fill.UserPicture "C:\Pic" & gridRow & ".bmp"
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
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
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
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
xlObj.ActiveWorkbook.Activ
you need to retrieve the correct image path before you insert that image into the Excel.