ti metto il codice della form1, dove ho posto la progress bar:
codice:
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Sub cmdAgg_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = OpenDatabase(App.Path & "\XML.mdb")
Dim msg, SQL As String
If ValidateEmail(txtDest.Text) = False Then
MsgBox "Indirizzo Email inserito non corretto!", vbCritical, "XML - AlphaTeam S.r.l."
Exit Sub
Else
msg = MsgBox("Desideri Aggiungere il seguente: " & txtDest.Text & " indirizzo di posta elettronica?", vbYesNo + vbQuestion, "XML - AlphaTeam S.r.l.")
If msg = vbYes Then
SQL = "INSERT INTO Email(Email) VALUES ('" & txtDest.Text & "')"
db.Execute (SQL)
MsgBox "Indirizzo Email: " & txtDest.Text & vbCrLf & " ... inserito correttamente. ", vbInformation, "XML - AlphaTeam S.r.l."
Else
MsgBox "Indirizzo Email: " & txtDest.Text & vbCrLf & " non inserito.", vbInformation, "XML - AlphaTeam S.r.l."
Exit Sub
End If
End If
End Sub
Private Sub cmdEmail_Click()
Dim msg, dest, ogg, ogg2, file As String, Ret As Long
If ValidateEmail(txtDest.Text) = False Then
Exit Sub
End If
If txtOgg.Text = "" Then
msg = MsgBox("Soggetto non Inserito in Email!!" & vbCrLf & "Desideri continuare comunque?", vbCritical + vbYesNo, "XML - AlphaTeam S.r.l.")
If msg = vbNo Then
Exit Sub
Else
txtOgg.Text = "-"
End If
End If
dest = txtDest.Text
ogg = txtOgg.Text
ogg2 = txtOgg2.Text
If txtnome.Text <> "" Then
If Right(txtnome.Text, 4) <> ".xml" Then
txtnome.Text = txtnome.Text + ".xml"
Else
End If
Else
MsgBox "Specificare un nome!!", vbCritical, "AlphaTeam - XML"
Exit Sub
End If
If chk1.Value = False Then
ShellExecute Me.hWnd, "Open", "mailto:" & dest & "?subject=" & ogg & "&body=" & ogg2, vbNullString, vbNullString, vbNormalFocus
Else
file = App.Path & "\" & txtnome.Text
ShellExecute Me.hWnd, "Open", "mailto:" & dest & "?subject=" & ogg & "&body=" & ogg2, vbNullString, vbNullString, vbNormalFocus
While Ret = 0
DoEvents
Ret = FindWindow(vbNullString, ogg)
Wend
SendKeys "%ia" & file & "{TAB}{TAB}{ENTER}"
End If
End Sub
Private Sub cmdXML_Click()
If txtnome.Text <> "" Then
If Right(txtnome.Text, 4) <> ".xml" Then
txtnome.Text = txtnome.Text + ".xml"
Else
End If
Else
MsgBox "Specificare un nome!!", vbCritical, "AlphaTeam - XML"
Exit Sub
End If
If Len(MaskEdBox1.Text) = 10 And Len(MaskEdBox1.Text) = 10 And MaskEdBox1.Text < MaskEdBox2.Text Then
txt1.Text = Trim$(Mid$(MaskEdBox1.Text, 7, 4)) & Trim$(Mid$(MaskEdBox1.Text, 4, 2)) & Trim$(Mid$(MaskEdBox1.Text, 1, 2))
txt2.Text = Trim$(Mid$(MaskEdBox2.Text, 7, 4)) & Trim$(Mid$(MaskEdBox2.Text, 4, 2)) & Trim$(Mid$(MaskEdBox2.Text, 1, 2))
Else
MsgBox "Selezionare un corretto intervallo di date!", vbCritical, "XML - AlphaTeam S.r.l."
Exit Sub
End If
Xml.Show
End Sub
e ora la form dove c'è il ciclo db che a seconda del numero dei record dovrebbe incrementare la progress bar posta nella form1, ecco il codice:
codice:
Private Sub Form_Load()
Centra Me
Dim xmldocument As DOMDocument
Dim rst As Recordset
Dim sellout As IXMLDOMElement
Dim vendita As IXMLDOMElement
Dim prodotto As IXMLDOMElement
Dim numero As IXMLDOMElement
Dim codpunto As IXMLDOMElement
Dim data As IXMLDOMElement
Dim codean As IXMLDOMElement
Dim coddpl As IXMLDOMElement
Dim quantita As IXMLDOMElement
Dim descrizione As IXMLDOMElement
Dim radice As String
Set xmldocument = New DOMDocument
Dim StrDSN As String
Dim rs As ADODB.Recordset
Dim StrQuery As Variant
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
StrDSN = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\XML.mdb;Mode=Read;Persist Security Info=False"
StrQuery = "SELECT * FROM XML WHERE DATA_DOCUMENTO BETWEEN " & Inizio.txt1.Text & " AND " & Inizio.txt2.Text & ""
cn.Open StrDSN
Set rs = cn.Execute(StrQuery)
If rs.RecordCount = 0 Then
MsgBox "Intervallo di date non corrispondenti in archivio!", vbCritical, "XML - AlphaTeam S.r.l."
Exit Sub
Else
xmldocument.async = False
radice = "SELL_OUT_GM"
Set sellout = xmldocument.createElement(radice)
xmldocument.appendChild sellout
Do While Not rs.EOF
Set vendita = xmldocument.createNode("element", "VENDITA", "")
Set numero = xmldocument.createElement("NUMERO")
Set codpunto = xmldocument.createElement("CODICE_PUNTO_VENDITA")
Set data = xmldocument.createElement("DATA")
vendita.appendChild numero
numero.Text = rs!A1_NUMERO_DOCUMENTO
vendita.appendChild codpunto
codpunto.Text = rs!A1_DEPOSITO_CODICE
vendita.appendChild data
data.Text = rs!DATA_DOCUMENTO
data.Text = Trim$(Mid$(data.Text, 7, 2)) & "/" & Trim$(Mid$(data.Text, 5, 2)) & "/" & Trim$(Mid$(data.Text, 1, 4))
Set prodotto = xmldocument.createNode("element", "PRODOTTO", "")
Set codean = xmldocument.createElement("CODICE_EAN")
Set quantita = xmldocument.createElement("QUANTITA")
Set descrizione = xmldocument.createElement("DESCRIZIONE")
vendita.appendChild prodotto
prodotto.appendChild codean
codean.Text = rs!A1_ARTICOLO_FORNITORE
prodotto.appendChild quantita
quantita.Text = rs!quantita
prodotto.appendChild descrizione
descrizione.Text = rs!descrizione
xmldocument.documentElement.appendChild vendita
Set vendita = Nothing
rs.MoveNext
Loop
xmldocument.save (App.Path + "\" + Inizio.txtnome)
WebBrowser1.Navigate App.Path + "\" + Inizio.txtnome
Set figlio = Nothing
Set xmldocument = Nothing
rs.Close
End If
End Sub
ORA TUTTO FUNZIONA BENE, SOLO CHE DAL FORM1 QUANDO ESEGUO L'ISTRUZIONE XML.SHOW ACCADE CHE CI STA 30 SECONDI O PIU, QUINDI VOLEVO CHE SULLA FORM1 DOVE RICHIAMO LA FORM2 CI SIA UN PROGRESS BAR, CHE UNA VOLTA ARRIVATA AL 100% SI APRA LA FORM2, MA NON VA DI PARI PASSO CON IL TEMPO, MA CON IL NUMERO DEI RECORD PROCESSATI NELLA FORM2.
AIUTO A TUTTI..
Permessi di invio
Rispondi quotando