Public Sub EliminaPedido(Num As Integer, Hoja1 As Worksheet)
and at main form:
Private Sub bBaja_Click()
Dim x10 As New Excel.Application
Dim ArchivoDestino As Workbook
Dim R As String
R = "Año " & Year(Now)
Set ArchivoDestino = x10.Workbooks.Open(Ruta & "\Registro pedidos.xlsx", 0)
Dim M As Integer
M = MsgBox("Desea eliminar el pedido " & Me.Range("H2").Value & " emitido a " & Me.Range("E11").Value & "?", vbExclamation + vbYesNo, "Pedidos de Elementos")
If M = 6 Then EliminaPedido Me.Range("H2").Value, ArchivoDestino.Worksheets(R)
ArchivoDestino.Close True
End Sub
When EliminaPedido ends, the object Hoja1 is freed or into that sub I must use set Hoja1 = Nothing?
Related
I have a function that logs when users run a report. It is set to run "on open". Is there a way to change the on open for all reports and forms at once?
This code loops through all forms:
Public Sub DoChangeModules()
Dim dstApp As Application
Dim dstDB As Database
Dim AO As Document
Set dstApp = Application
Set dstDB = dstApp.CurrentDb
' iterate forms's modules and insert code
Dim f As Form
Dim M As Module
Debug.Print "Modifying Modules:"
Debug.Print "Forms:"
For Each AO In dstDB.Containers("Forms").Documents
dstApp.DoCmd.OpenForm AO.Name, acViewDesign
Set f = dstApp.Forms(AO.Name)
Set M = f.Module
ProccessModule M
Set f = Nothing
dstApp.DoCmd.Close acForm, AO.Name, acSaveYes
Next AO
End Sub
Public Sub ProccessModule(M As Module)
Dim numLine As Long
Dim StartLine As Long, StartColumn As Long, EndLine As Long, EndColumn As Long
Debug.Print , , M.Name
' insert variable declaration
M.AddFromString "Private testVar As variant ' test addition of module-level variable"
' locate or create Load event procedure
StartLine = 0
StartColumn = 0
EndLine = 0
EndColumn = 0
If Not M.Find(" Form_Open(", StartLine, StartColumn, EndLine, EndColumn) Then
numLine = M.CreateEventProc("Open", "Form")
End If
numLine = M.ProcBodyLine("Form_Open", 0) ' 0 here is vbext_pk_Proc
M.InsertLines numLine + 1, "" & _
" ' Call of global function that logs user" & vbNewLine & _
" doLogUser testVar " & vbNewLine & _
" ' that function called with local module variable "
End Sub
I am running a search in certain folders and their subfolders to move all items in a common parent folder.
When the search is done I get an Outlook.Results item rsts and then want to move all items in the search result. I am at the step where I loop all items, but the last item throws a 440 at the GetNext Method. How can I solve this?
---------------------------
Microsoft Visual Basic for Applications
---------------------------
Run-time error '440':
The object does not support this method.
---------------------------
OK Help
---------------------------
My Code
Public blnSearchComp As Boolean
Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)
blnSearchComp = True
End Sub
Sub SearchAllEmailsInFolder(oFolder As Folder)
Dim sch As Outlook.Search
Dim rsts As Outlook.Results
blnSearchComp = False
Dim Scope As String
Dim Filter As String
Scope = "'" & oFolder.FolderPath & "'"
Filter = "urn:schemas:mailheader:subject = '' OR urn:schemas:mailheader:subject <> ''"
Set sch = Application.AdvancedSearch(Scope, Filter, True)
While blnSearchComp = False
DoEvents
Wend
Set rsts = sch.Results
Debug.Print rsts.Count & vbCr & "------------"
Dim i As Object
Set i = rsts.GetFirst
Do While Not i Is Nothing
Debug.Print "Move '" & i.Subject & "' to '" & oFolder.Parent.FolderPath & "'"
'i.Move(oFolder.Parent)
i = rsts.GetNext ' <------------------- 440 thrown here, if it is last item.
Loop
End Sub
Sub Start()
Dim oRootFolder As Folder
Set oRootFolder = ActiveExplorer.CurrentFolder
LoopFolders oRootFolder
End Sub
Private Sub LoopFolders(oParentFolder As Folder)
Dim f As Folder
For Each f In oParentFolder.Folders
If f.Name = "2774DD0F-B27D-41CA-9448-4BFBF1EC8AAB" Then
'Search here
Debug.Print f.FolderPath
SearchAllEmailsInFolder f
Else
Debug.Print f.Name
LoopFolders f
End If
Next
End Sub
I have a VBA module that receives a database object, worksheet name, and two column field names as parameters to make a SQL query into another Excel table that has over 1,000,000 rows with information. But when I was debugging I noticed that my VBA code does not return the info after the row number 65,000 (approximately). This is returning wrong info and not acting properly as expected.
So, how can I handle it in my existing code?
Here is my code:
Functions
Const diretorioSA = "C:\Users\Bosch-PC\Desktop\dbLEGENDAS_ELETROPAR\"
Const BaseEletro = "dbClientesEletropar.xlsb"
Const dbClientes = "CLIENTESLDA"
Public Function Number2Letter(ByVal ColNum As Long) As String
Dim ColumnNumber As Long
Dim ColumnLetter As String
ColumnNumber = ColNum
ColumnLetter = Split(Cells(1, ColumnNumber).Address, "$")(1)
Number2Letter = ColumnLetter
End Function
Public Function GetWorkbook(ByVal sFullName As String) As Workbook
Dim sFile As String
Dim wbReturn As Workbook
sFile = DIR(sFullName)
On Error Resume Next
Set wbReturn = Workbooks(sFile)
If wbReturn Is Nothing Then
Set wbReturn = Workbooks.Open(sFullName)
End If
On Error GoTo 0
Set GetWorkbook = wbReturn
End Function
Public Function ReplaceChars(ByVal str As String, ByVal Lista As String) As String
Dim buff(), buffChars() As String
ReDim buff(Len(str) - 1): ReDim buffChars(Len(Lista) - 1)
For i = 1 To Len(str): buff(i - 1) = Mid$(str, i, 1): Next
For i = 1 To Len(Lista): buffChars(i - 1) = Mid$(Lista, i, 1): Next
For strEle = 0 To UBound(buff)
For listaEle = 0 To UBound(buffChars)
If buff(strEle) = buffChars(listaEle) Then
buff(strEle) = ""
End If
Next listaEle
novoTexto = novoTexto & buff(strEle)
Next strEle
ReplaceChars = novoTexto
End Function
Function ConsultaBaseDeDadosELETRO(ByVal CAMPO_PESQUISA As String, _
ByVal CAMPO_RETORNO As String, _
ByVal NOME_PLANILHA As String, _
ByRef BASES As Object, _
ByVal ARGUMENTO As String) As String
On Error GoTo ERRO:
Debug.Print BASES.Name
Dim RSt22 As Recordset
Set RSt22 = BASES.OpenRecordset("SELECT [" & CAMPO_RETORNO & "] FROM [" & NOME_PLANILHA & "$] WHERE [" & CAMPO_PESQUISA & "] IN ('" & ARGUMENTO & "') ;", dbOpenForwardOnly, dbReadOnly)
Debug.Print RSt22.CacheSize & " | CONTAGEM: " & RSt22.RecordCount
ConsultaBaseDeDadosELETRO = RSt22(CAMPO_RETORNO)
Exit Function
ERRO:
Debug.Print VBA.Err.Description & " | Error number: " & VBA.Err.Number & " | " & VBA.Err.HelpFile
ConsultaBaseDeDadosELETRO = "Sem registros"
End Function
Main Subroutine
Sub ProcurarBaseEletro(ByVal PASTA As String, ByVal ARQUIVO As String, ByVal NOME_PLANILHA As String, ByVal CAMPO As String)
If ActiveCell.value = "CGC" Or ActiveCell.value = "CNPJ" Or ActiveCell.value = "cgc" Or ActiveCell.value = "cnpj" Then
Application.ScreenUpdating = False
Dim wks As Worksheet: Set wks = ActiveSheet
Dim db2 As database
Dim CellRow As Single
Dim Cellcol_info, CellCol As String
Dim DiretorioBase As String: DiretorioBase = diretorioSA & BaseEletro
Dim wb As Workbook: Set wb = GetWorkbook(DiretorioBase)
If wb Is Nothing Then
MsgBox "Base de dados não localizada!" & vbNewLine & "EM: " & DiretorioBase, vbCritical, "Atenção"
Set wb = Nothing
Set wks = Nothing
Application.ScreenUpdating = True
Exit Sub
Else
wks.Activate
CellRow = ActiveCell.row
CellCol = Number2Letter(ActiveCell.Column)
Cellcol_info = Number2Letter(ActiveCell.Column + 1)
CELLCOL_LROW = ActiveSheet.Cells(ActiveSheet.Rows.Count, CellCol).End(xlUp).row
Set db2 = OpenDatabase(DiretorioBase, False, False, "Excel 8.0")
Columns(Cellcol_info & ":" & Cellcol_info).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cellcol_info & CellRow).value = CAMPO
Dim Query As String
Dim CelAtivaValue As String
For i = CellRow + 1 To CELLCOL_LROW
CelAtivaValue = UCase(Cells(i, CellCol).value)
Query = ReplaceChars(CelAtivaValue, "/.- ")
If Left(Query, 6) < 132714 Then
Cells(i, Cellcol_info).value = ConsultaBaseDeDadosELETRO("CGC", CAMPO, NOME_PLANILHA, db2, Query)
Else
Cells(i, Cellcol_info).value = ConsultaBaseDeDadosELETRO("CGC", CAMPO, NOME_PLANILHA & 2, db2, Query)
End If
Next i
wb.Close
End If
Else
MsgBox "Texto da Célula ativa não é CGC/CNPJ, impossível fazer pesquisa", vbCritical, "Valor célula ativa: " & ActiveCell.value
Application.ScreenUpdating = True
Exit Sub
End If
Cells.EntireColumn.AutoFit
MsgBox "Processo concluído com sucesso.", vbOKOnly, "Informativo do sistema"
Application.ScreenUpdating = True
End Sub
Older Excel formats (.xls) maintains a worksheet limit of 2^16 (65536) rows. Current Excel formats (.xlsx) maintains a worksheet limit of 2^20 (1,048,576) rows.
Likely, you have a more recent version of MS Office (2007+) (given the .xlsb in BaseEletro) but your DAO code was not updated. Consider adjusting the DAO.OpenDatabase option to the newer current format.
From
Set db2 = OpenDatabase(DiretorioBase, False, False, "Excel 8.0")
To
Set db2 = OpenDatabase(DiretorioBase, False, False, "Excel 12.0 Xml")
I'm trying develop a macro that runs renders and saves them automatically. The files (with path) are listed, and extracted from an Excel file, then opened and rendered.
This part works fine, but now I would like to remove the floor shades (and floor reflections) within the VBA code. I tried to record a macro while turning off the floor shades in a random SolidWorks file, but SolidWorks unfortunately doesn't record this part.
Does any one have a solution for this?
Thanks in advance
'
******************************************************************************
' C:\Users\Omar\AppData\Local\Temp\swx11684\Macro1.swb - macro recorded on 11/25/16 by Omar
' ******************************************************************************
Sub main()
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim status As Boolean
Set swApp = Application.SldWorks
Dim i As String
Dim j As String
Dim y As Integer
Dim z As String
Dim n As Integer
Dim m As Integer
Dim swModel As SldWorks.ModelDoc2
Dim swRayTraceRenderer As SldWorks.RayTraceRenderer
Dim swRayTraceRenderOptions As SldWorks.RayTraceRendererOptions
Dim errors As Long
Dim warnings As Long
Dim filePath As String
Dim Scene As SldWorks.SWScene
Dim swConfig As SldWorks.Configuration
Dim swPoint As SldWorks.MathPoint
Dim point As Variant
Dim swVector As SldWorks.MathVector
Dim vect As Variant
'Dim xlApp As Object, xlWB As Object
'Set xlApp = CreateObject("Excel.Application")
'i = file name
'j = file extention
'i = "bp01p0006" example
'j = "simbeton - Solidworks\bp - betonplaten\bp01 - simvlak\" example
'Set xlWB = xlApp.Workbooks.Open(“C:\Users\Omar\Desktop\Renders Rob\Lijst.xlsx”)
y = 0
n = 0
Do While n < 5
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Set xlApp = New Excel.Application
Set xlWB = xlApp.Workbooks.Open("C:\Users\Omar\Desktop\Renders Rob\Lijst.xlsx")
If xlWB.Worksheets(1).Range("A1").offset(y, 0) = "" Then
y = y + 1
n = n + 1
Else
j = xlWB.Worksheets(1).Range("A1").offset(y, 0).value
i = xlWB.Worksheets(1).Range("A1").offset(y, 1).value
z = xlWB.Worksheets(1).Range("A1").offset(y, 2).value
xlWB.Worksheets(1).Range("A1").offset(y, 0) = ""
y = y + 1
End If
Set xlWB = Nothing
Set xlApp = Nothing
filePath = "" & j & "\" & i & ".SLDPRT"
Set swModel = swApp.OpenDoc6(filePath, swDocPART, swOpenDocOptions_Silent, "", errors, warnings)
Set Part = swApp.ActiveDoc
Set swApp = _
Application.SldWorks
Dim myModelView As Object
Set myModelView = Part.ActiveView
myModelView.AddPerspective
Part.ViewZoomtofit2
Part.ViewZoomtofit2
Part.ViewZoomtofit2
Part.ViewZoomtofit2
Part.ViewZoomtofit2
Part.ShowNamedView2 "*Isometric", 7
Part.ViewZoomtofit2
Part.ViewDisplayShaded
Dim activeModelView As Object
Set activeModelView = Part.ActiveView
activeModelView.DisplayMode = swViewDisplayMode_e.swViewDisplayMode_ShadedWithEdges
Part.ClearSelection2 True
boolstatus = Part.Extension.SketchBoxSelect("0.000000", "0.000000", "0.000000", "0.000000", "0.000000", "0.000000")
Part.ViewDisplayShaded
' Access PhotoView 360
Set swRayTraceRenderer = swApp.GetRayTraceRenderer(swPhotoView)
' Get and set rendering options
Set swRayTraceRenderOptions = swRayTraceRenderer.RayTraceRendererOptions
'Get current rendering values
Debug.Print "Current rendering values"
Debug.Print " ImageHeight = " & swRayTraceRenderOptions.ImageHeight
Debug.Print " ImageWidth = " & swRayTraceRenderOptions.ImageWidth
Debug.Print " ImageFormat = " & swRayTraceRenderOptions.ImageFormat
Debug.Print " PreviewRenderQuality = " & swRayTraceRenderOptions.PreviewRenderQuality
Debug.Print " FinalRenderQuality = " & swRayTraceRenderOptions.FinalRenderQuality
Debug.Print " BloomEnabled = " & swRayTraceRenderOptions.BloomEnabled
Debug.Print " BloomThreshold = " & swRayTraceRenderOptions.BloomThreshold
Debug.Print " BloomRadius = " & swRayTraceRenderOptions.BloomRadius
Debug.Print " ContourEnabled = " & swRayTraceRenderOptions.ContourEnabled
Debug.Print " ShadedContour = " & swRayTraceRenderOptions.ShadedContour
Debug.Print " ContourLineThickness = " & swRayTraceRenderOptions.ContourLineThickness
Debug.Print " ContourLineColor = " & swRayTraceRenderOptions.ContourLineColor
Debug.Print " "
'Change rendering values
Debug.Print "New rendering values"
swRayTraceRenderOptions.ImageHeight = 405
Debug.Print " ImageHeight = " & swRayTraceRenderOptions.ImageHeight
swRayTraceRenderOptions.ImageWidth = 720
Debug.Print " ImageWidth = " & swRayTraceRenderOptions.ImageWidth
swRayTraceRenderOptions.ImageFormat = swImageFormat_PNG
Debug.Print " ImageFormat = " & swRayTraceRenderOptions.ImageFormat
swRayTraceRenderOptions.PreviewRenderQuality = swRenderQuality_Better
Debug.Print " PreviewRenderQuality = " & swRayTraceRenderOptions.PreviewRenderQuality
swRayTraceRenderOptions.FinalRenderQuality = swRenderQuality_Best
Debug.Print " FinalRenderQuality = " & swRayTraceRenderOptions.FinalRenderQuality
swRayTraceRenderOptions.BloomEnabled = False
Debug.Print " BloomEnabled = " & swRayTraceRenderOptions.BloomEnabled
swRayTraceRenderOptions.BloomThreshold = 0
Debug.Print " BloomThreshold = " & swRayTraceRenderOptions.BloomThreshold
swRayTraceRenderOptions.BloomRadius = 0
Debug.Print " BloomRadius = " & swRayTraceRenderOptions.BloomRadius
swRayTraceRenderOptions.ContourEnabled = False
Debug.Print " ContourEnabled = " & swRayTraceRenderOptions.ContourEnabled
swRayTraceRenderOptions.ShadedContour = False
Debug.Print " ShadedContour = " & swRayTraceRenderOptions.ShadedContour
swRayTraceRenderOptions.ContourLineThickness = 0
Debug.Print " ContourLineThickness = " & swRayTraceRenderOptions.ContourLineThickness
swRayTraceRenderOptions.ContourLineColor = 255
Debug.Print " ContourLineColor = " & swRayTraceRenderOptions.ContourLineColor
' Display the preview window
status = swRayTraceRenderer.DisplayPreviewWindow
' Close render
status = swRayTraceRenderer.CloseRayTraceRender
' Invoke final render window
status = swRayTraceRenderer.InvokeFinalRender
' Abort final render window
status = swRayTraceRenderer.AbortFinalRender
' Render to Windows Bitmap format
status = swRayTraceRenderer.RenderToFile("C:\Users\Omar\Desktop\Renders Rob\" & i & z & ".png", 0, 0)
swRayTraceRenderOptions.FinalRenderQuality = swRenderQuality_Good
' Render to HDR format (format extension omitted)
status = swRayTraceRenderer.RenderToFile("C:\Users\Omar\Desktop\Renders Rob\" & i & z, 0, 0)
Set swRayTraceRenderOptions = Nothing
' Close render
status = swRayTraceRenderer.CloseRayTraceRender
swApp.QuitDoc i
Loop
End Sub
With Solidworks tutorials : FloorShadows Property (ISwScene)
Option Explicit
Dim Scene As SldWorks.SWScene
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swConfig As SldWorks.Configuration
Dim swPoint As SldWorks.MathPoint
Dim swVector As SldWorks.MathVector
Dim point As Variant
Dim vect As Variant
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swConfig = swModel.GetActiveConfiguration
Debug.Print "Configuration: " & swConfig.Name
Set Scene = swConfig.GetScene
Dim P2SFilename As String
Scene.GetP2SFileName P2SFilename
Debug.Print "Scene file: " & P2SFilename
Scene.GetFloorNormal swPoint, swVector
point = swPoint.ArrayData
Debug.Print "Scene floor normal point: " & point(0) & ", " & point(1) & ", " & point(2)
vect = swVector.ArrayData
Debug.Print "Scene floor normal vector: " & vect(0) & ", " & vect(1) & ", " & vect(2)
Dim value As Boolean
Scene.FloorShadows = False '<- Here !
value = Scene.FloorShadows 'debug
Scene.BackgroundType = swSceneBackgroundType_e.swBackgroundType_UseEnvironment
Debug.Print "Type of scene background as defined in swSceneBackgroundType_e: " & Scene.BackgroundType
Debug.Print "Scene background environment image file: " & Scene.BackgroundEnvImage
Debug.Print "Scene background image file: " & Scene.BackgroundImage
Debug.Print "Scene environment rotation: " & Scene.EnvironmentRotation
Scene.FitToSWWindow = True
Debug.Print "Stretch to fit in SOLIDWORKS window? " & Scene.FitToSWWindow
Debug.Print "Scale the scene floor uniformly? " & Scene.FixedAspectRatio
Debug.Print "Flip the scene floor direction? " & Scene.FloorDirection
Debug.Print "Automatically resize the scene floor based on the model bounding box? " & Scene.FloorAutoSize
Debug.Print "Distance between scene floor and model: " & Scene.FloorOffset
Debug.Print "Flip the scene floor offset direction? " & Scene.FloorOffsetDirection
Scene.FloorReflections = True
Debug.Print "Show model reflections on the scene floor? " & Scene.FloorReflections
Debug.Print "Scene floor rotation: " & Scene.FloorRotation
Debug.Print "Show model shadows on the scene floor? " & Scene.FloorShadows
Debug.Print "Keep the scene background when changing the scene? " & Scene.KeepBackground
Scene.FlattenFloor = True
Debug.Print "Flatten the scene floor of the spherical environment? " & Scene.FlattenFloor
Debug.Print "Horizon height: " & Scene.HorizonHeight
Debug.Print "Environment size: " & Scene.EnvironmentSize
End Sub
I have the following sub
Public Sub Transfer()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim Searching_Date As String
Dim Name As String
Dim Presente As Boolean
Dim Foto_Presente As Boolean
For i = 0 To CDIi - 1
Searching_Date = Image_Date(Camera_Day_Images(i))
Name = Replace(Camera_Day_Images(i), Camera & Path_in_Camera & "\", "")
Presente = False
j = 0
While (Not Presente And j <= PCi)
If (Path & "\" & Right_Date(Searching_Date)) = PC_Directory(j) Then
Presente = True
Else
Presente = False
End If
j = j + 1
End While
If Presente = True Then
Foto_Presente = False
k = 0
List_PC_Day_Images(Path & "\" & Right_Date(Searching_Date))
While (Not Foto_Presente And k <= PDIi)
If (Path & "\" & Right_Date(Searching_Date) & "\" & Name) = PC_Day_Images(k) Then
Foto_Presente = True
Else
Foto_Presente = False
End If
k = k + 1
End While
If Foto_Presente = True Then
Else
My.Computer.FileSystem.CopyFile(Camera & Path_in_Camera & "\" & Name, Path & "\" & Right_Date(Searching_Date) & "\" & Name)
PC_Day_Images(PDIi) = Path & "\" & Right_Date(Searching_Date) & "\" & Name
PDIi = PDIi + 1
End If
Else
My.Computer.FileSystem.CreateDirectory(Path & "\" & Right_Date(Searching_Date))
My.Computer.FileSystem.CopyFile(Camera & Path_in_Camera & "\" & Name, Path & "\" & Right_Date(Searching_Date) & "\" & Name)
End If
Next
Principale.LFine.Text = "Tutte le tue foto sono state trasferite con successo"
Principale.Button1.Enabled = False
End Sub
It copies any photos from my device to my computer. So if I have a lot of photos It can take several time and I want to notify this. In fact I change the text in the label, than I call the Sub and finally rechange the label.
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
LFine.Text = "attendere prego..."
Transfer()
LFine.Text = "Operazione completata con successo"
End Sub
But the results are that Transfer () starts and just after he finished changing the label.
Why??? How can I fix this problem??
Thank you.
After LFine.Text = "attendere prego..." add this line:
LFine.Update()
See https://msdn.microsoft.com/en-us/library/vstudio/system.windows.forms.control.update(v=vs.100).aspx
Wrap the call to tranfers() in an if statement
Change your Sub to a Function,
Public Function Transfer() As Boolean
...
then
If tranfers() = true then
LFine.Text = "Operazione completata con successo"
End if
That is because your process is a blocking process. The label is "updated" but the form is redrawn only after the whole process ends. Others have suggested to use Application.DoEvents() or LFine.Update, but the best way to do what you want is to make your process parallel.
You could use a BackgroundWorker for this:
Imports System.ComponentModel
Dim bgw As New BackgroundWorker
In the Load event of your form...
AddHandler bgw.DoWork, AddressOf bgw_DoWork
AddHandler bgw.RunWorkerCompleted, AddressOf bgw_RunWorkerCompleted
And then set your code like this...
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
LFine.Text = "attendere prego..."
bgw.RunWorkerAsync()
End Sub
Private Sub bgw_DoWork(ByVal sender As System.Object, ByVal e As System.ComponentModel.DoWorkEventArgs) Handles bgw.DoWork
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim Searching_Date As String
Dim Name As String
Dim Presente As Boolean
Dim Foto_Presente As Boolean
For i = 0 To CDIi - 1
Searching_Date = Image_Date(Camera_Day_Images(i))
Name = Replace(Camera_Day_Images(i), Camera & Path_in_Camera & "\", "")
Presente = False
j = 0
While (Not Presente And j <= PCi)
If (Path & "\" & Right_Date(Searching_Date)) = PC_Directory(j) Then
Presente = True
Else
Presente = False
End If
j = j + 1
End While
If Presente = True Then
Foto_Presente = False
k = 0
List_PC_Day_Images(Path & "\" & Right_Date(Searching_Date))
While (Not Foto_Presente And k <= PDIi)
If (Path & "\" & Right_Date(Searching_Date) & "\" & Name) = PC_Day_Images(k) Then
Foto_Presente = True
Else
Foto_Presente = False
End If
k = k + 1
End While
If Foto_Presente = True Then
Else
My.Computer.FileSystem.CopyFile(Camera & Path_in_Camera & "\" & Name, Path & "\" & Right_Date(Searching_Date) & "\" & Name)
PC_Day_Images(PDIi) = Path & "\" & Right_Date(Searching_Date) & "\" & Name
PDIi = PDIi + 1
End If
Else
My.Computer.FileSystem.CreateDirectory(Path & "\" & Right_Date(Searching_Date))
My.Computer.FileSystem.CopyFile(Camera & Path_in_Camera & "\" & Name, Path & "\" & Right_Date(Searching_Date) & "\" & Name)
End If
Next
End Sub
Private Sub bgw_RunWorkerCompleted(ByVal sender As System.Object, ByVal e As System.ComponentModel.RunWorkerCompletedEventArgs) Handles bgw.RunWorkerCompleted
Principale.LFine.Text = "Tutte le tue foto sono state trasferite con successo"
Principale.Button1.Enabled = False
End Sub
Just make sure you don't access any control of your form inside bgw_DoWork method.