Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

VBA Répétition

samanall

XLDnaute Nouveau
bonjour a toute et a tous
je travail pour une societe allemande et je dois écrire un programme qui me permettra de me connecter a un webserveur(webservice), pour ensuite recuperer des infos.
j'ai reussi a écrire le programme en question mais le probleme c'est que la macro dois se répéter sur les ligne suivante. est ce que qqn pourrai m'aider svp?
voici la macro et j'ai aussi joint le fichier:

Type dsoinfo
name As String
regelzone As String
End Type
Dim dso As dsoinfo
Public Function Abfrage(plz As String, ort As String) As Variant
Abfrage = plz
'Dim ort As String
' ort = getOrt(plz)
'If ort = "" Then
' MsgBox "Kein Ort zu PLZ gefunden!", , "Achtung"
' Exit Function
'End If
Dim dso As String
dso = getDSO(plz, ort)
If dso = "" Then
MsgBox "Fehler Webservice!", , "Achtung"
Exit Function
End If
Call getEntgelt(plz, dso)
End Function
Private Function getOrt(plz As String) As String
Dim s As New NotesSession
If s Is Nothing Then
getOrt = ""
MsgBox "Notes Fehler!", , "Achtung"
Exit Function
End If
Call s.Initialize
Dim targetdb As NotesDatabase
Set targetdb = s.GetDatabase("Duisburg6/PCC", "get\wsr.nsf", False)
If Not targetdb.IsOpen Then
MsgBox "Webservice nicht erreichbar!", , "Achtung"
getOrt = ""
Exit Function
End If
Dim RQdoc As NotesDocument
Set RQdoc = targetdb.CreateDocument
Call RQdoc.ReplaceItemValue("Form", "Request")
Dim varTmp As Variant
Dim varTmp2 As Variant
varTmp = s.Evaluate("@DocumentUniqueID", RQdoc)
varTmp2 = s.Evaluate("@Unique", RQdoc)
Call RQdoc.ReplaceItemValue("RQID", "RQ" & varTmp2(0) & "/" & varTmp(0))
Call RQdoc.ReplaceItemValue("Param.AbnahmePLZ", plz)
Call RQdoc.ReplaceItemValue("Param.Date", CStr(Date))
Call RQdoc.ReplaceItemValue("Param.Type", "Ort")
Call RQdoc.ReplaceItemValue("SaveOptions", "1")
Call RQdoc.ComputeWithForm(False, False)
Call RQdoc.Save(True, False)
Dim agent As NotesAgent
Set agent = targetdb.GetAgent("Get.Ortsservice")
Call agent.RunOnServer(RQdoc.NoteID)
Dim rsview As NotesView
Set rsview = targetdb.GetView("Lookup.Result.RSID")
Dim RSdoc As NotesDocument
Call rsview.Refresh
Set RSdoc = rsview.GetDocumentByKey(RQdoc.GetItemValue("RQID"), True)
If Not RSdoc Is Nothing Then
Dim maske As New UserForm1
For Each orte In RSdoc.GetItemValue("Result.AbnahmeOrt")
maske.ComboBox1.AddItem (orte)
'Ort = Ort & orte & ","
Next
maske.ComboBox1.ListIndex = 0
maske.Show
getOrt = CStr(maske.ComboBox1.Value)
Else
MsgBox "Kein Result!", , "Achtung"
getOrt = ""
End If
End Function
Private Function getDSO(plz As String, ort As String) As String
Dim s As New NotesSession
If s Is Nothing Then
getDSO = ""
MsgBox "Notes Fehler!", , "Achtung"
Exit Function
End If
Call s.Initialize
Dim targetdb As NotesDatabase
Set targetdb = s.GetDatabase("Duisburg6/PCC", "get\wsr.nsf", False)
If Not targetdb.IsOpen Then
MsgBox "Webservice nicht erreichbar!", , "Achtung"
getDSO = ""
Exit Function
End If
Dim RQdoc As NotesDocument
Set RQdoc = targetdb.CreateDocument
Call RQdoc.ReplaceItemValue("Form", "Request")
Dim varTmp As Variant
Dim varTmp2 As Variant
varTmp = s.Evaluate("@DocumentUniqueID", RQdoc)
varTmp2 = s.Evaluate("@Unique", RQdoc)
Call RQdoc.ReplaceItemValue("RQID", "RQ" & varTmp2(0) & "/" & varTmp(0))
Call RQdoc.ReplaceItemValue("Param.AbnahmePLZ", plz)
Call RQdoc.ReplaceItemValue("Param.AbnahmeOrt", ort)
Call RQdoc.ReplaceItemValue("Param.Date", CStr(Date))
Call RQdoc.ReplaceItemValue("Param.Type", "DSO")
Call RQdoc.ReplaceItemValue("SaveOptions", "1")
Call RQdoc.ComputeWithForm(False, False)
Call RQdoc.Save(True, False)
Dim agent As NotesAgent
Set agent = targetdb.GetAgent("Get.Ortsservice")
Call agent.RunOnServer(RQdoc.NoteID)
Dim rsview As NotesView
Set rsview = targetdb.GetView("Lookup.Result.RSID")
Dim RSdoc As NotesDocument
Call rsview.Refresh
Set RSdoc = rsview.GetDocumentByKey(RQdoc.GetItemValue("RQID"), True)
If Not RSdoc Is Nothing Then
If RSdoc.GetItemValue("Result.Success")(0) = "True" Then
If UBound(RSdoc.GetItemValue("Result.name")) > 0 Then
Dim maske As New UserForm1
For Each name In RSdoc.GetItemValue("Result.name")
maske.ComboBox1.AddItem (name)
Next
maske.ComboBox1.ListIndex = 0
maske.Show
chosen = maske.ComboBox1.Value
Dim i As Integer

For i = 0 To UBound(RSdoc.GetItemValue("Result.name"))
If RSdoc.GetItemValue("Result.name")(i) = chosen Then
With ThisWorkbook.Worksheets(1)
'ort
.Range("E7") = ort

'Netzbetreiber
.Range("F7") = CStr(RSdoc.GetItemValue("Result.name")(i))
'Regelzone
.Range("G7") = CStr(RSdoc.GetItemValue("Result.regelzone")(i))
getDSO = CStr(RSdoc.GetItemValue("Result.vdewid")(i))
End With
Exit For
End If
Next
Else
With ThisWorkbook.Worksheets(1)
.Range("E7") = ort
.Range("F7") = CStr(RSdoc.GetItemValue("Result.name")(0))
.Range("G7") = CStr(RSdoc.GetItemValue("Result.regelzone")(0))
getDSO = CStr(RSdoc.GetItemValue("Result.vdewid")(0))
End With
End If
Else
MsgBox "Netzbetreiber konnte nicht gefunden werden. Bitte überprüfen Sie die Kombination PLZ + Ort.", , "Fehler"
getDSO = ""
Exit Function
End If
Else
MsgBox "Kein Result!", , "Achtung"
getDSO = ""
End If
End Function
Private Sub getEntgelt(plz As String, dso As String)
Dim s As New NotesSession
If s Is Nothing Then
MsgBox "Notes Fehler!", , "Achtung"
Exit Sub
End If
Call s.Initialize
Dim targetdb As NotesDatabase
Set targetdb = s.GetDatabase("Duisburg6/PCC", "get\wsr.nsf", False)
If Not targetdb.IsOpen Then
MsgBox "Webservice nicht erreichbar!", , "Achtung"
Exit Sub
End If
Dim RQdoc As NotesDocument
Set RQdoc = targetdb.CreateDocument
Call RQdoc.ReplaceItemValue("Form", "Request")
Dim varTmp As Variant
Dim varTmp2 As Variant
varTmp = s.Evaluate("@DocumentUniqueID", RQdoc)
varTmp2 = s.Evaluate("@Unique", RQdoc)
Call RQdoc.ReplaceItemValue("RQID", "RQ" & varTmp2(0) & "/" & varTmp(0))
'Leistung


If ThisWorkbook.Worksheets(1).Range("P7").Value = "" Then
Call RQdoc.ReplaceItemValue("Param.Leistung", 0)


Else
Call RQdoc.ReplaceItemValue("Param.Leistung", ThisWorkbook.Worksheets(1).Range("P7").Value)

End If


Call RQdoc.ReplaceItemValue("Param.PLZ", plz)
Call RQdoc.ReplaceItemValue("Param.Jahresgesamtverbrauch", ThisWorkbook.Worksheets(1).Range("O7").Value)
Call RQdoc.ReplaceItemValue("Param.Date", CStr(ThisWorkbook.Worksheets(1).Range("J7").Value))

If ThisWorkbook.Worksheets(1).Range("L7").Value = "NSP ohne LM" Then
Call RQdoc.ReplaceItemValue("Param.spannungsebenemessung", "E06")
Call RQdoc.ReplaceItemValue("Param.spannungsebeneentnahme", "E06")
End If
If ThisWorkbook.Worksheets(1).Range("L7").Value = "NSP mit LM" Then
Call RQdoc.ReplaceItemValue("Param.spannungsebenemessung", "E06")
Call RQdoc.ReplaceItemValue("Param.spannungsebeneentnahme", "E06")
End If
If ThisWorkbook.Worksheets(1).Range("L7").Value = "MSP" Then
Call RQdoc.ReplaceItemValue("Param.spannungsebenemessung", "E05")
Call RQdoc.ReplaceItemValue("Param.spannungsebeneentnahme", "E05")
End If
If ThisWorkbook.Worksheets(1).Range("L7").Value = "MSU" Then
Call RQdoc.ReplaceItemValue("Param.spannungsebenemessung", "E09")
Call RQdoc.ReplaceItemValue("Param.spannungsebeneentnahme", "E06")
End If
If ThisWorkbook.Worksheets(1).Range("L7").Value = "MS/NS" Then
Call RQdoc.ReplaceItemValue("Param.spannungsebenemessung", "E05")
Call RQdoc.ReplaceItemValue("Param.spannungsebeneentnahme", "E06")
End If
Call RQdoc.ReplaceItemValue("Param.Type", "Entgelt")
Call RQdoc.ReplaceItemValue("Param.DSONr", dso)
Call RQdoc.ReplaceItemValue("SaveOptions", "1")
Call RQdoc.ComputeWithForm(False, False)
Call RQdoc.Save(True, False)
Dim agent As NotesAgent
Set agent = targetdb.GetAgent("Get.Stromservice")
Call agent.RunOnServer(RQdoc.NoteID)
Dim rsview As NotesView
Set rsview = targetdb.GetView("Lookup.Result.RSID")
Dim RSdoc As NotesDocument
Call rsview.Refresh
Set RSdoc = rsview.GetDocumentByKey(RQdoc.GetItemValue("RQID"), True)
If Not RSdoc Is Nothing Then
If RSdoc.HasItem("Result.Error") Then
MsgBox "Fehler: " & RSdoc.GetItemValue("Result.Error")(0), , "Achtung"
Exit Sub
End If
With ThisWorkbook.Worksheets(1)
'Arbeitspreis
.Range("Y7") = CDbl(Replace(RSdoc.GetItemValue("Result.Wirkarbeit")(0), ".", ",")) * 100 / CDbl(ThisWorkbook.Worksheets(1).Range("O7").Value)
.Range("X7") = CDbl(Replace(RSdoc.GetItemValue("Result.Wirkarbeit")(0), ".", ",")) * 100 / CDbl(ThisWorkbook.Worksheets(1).Range("O7").Value)
If CDbl(ThisWorkbook.Worksheets(1).Range("P7").Value) > 0 Then
'Leistungspreis
.Range("W7") = CDbl(Replace(RSdoc.GetItemValue("Result.Leistung")(0), ".", ",")) / CDbl(ThisWorkbook.Worksheets(1).Range("P7").Value)
End If
'Messkosten
.Range("AA7") = CDbl(Replace(RSdoc.GetItemValue("Result.entgelt_zaehlerpreis_ablesung")(0), ".", ",")) + CDbl(Replace(RSdoc.GetItemValue("Result.entgelt_fuer_abrechnung")(0), ".", ","))
'Grundpreis
End With
Else
MsgBox "Kein Result!", , "Achtung"
End If
Exit Sub
End Sub
 

Pièces jointes

  • Kalkulation_Strom_test.xlsm
    111.9 KB · Affichages: 80

Paritec

XLDnaute Barbatruc
Re : VBA Répétition

Bonjour Samanal le forum
bon alors tu dis avoir ÉCRIT cette macro et tu ne sais pas faire une boucle ??????
là franchement devant tant de mauvaise foi, je ne peux pas répondre!!
a+
papou
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…