home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / WebSvc20938112142007.psc / fMain.frm < prev    next >
Text File  |  2007-12-14  |  12KB  |  433 lines
  1. VERSION 5.00
  2. Begin VB.Form fMain 
  3.    Caption         =   "File Transmission to Web Service"
  4.    ClientHeight    =   4200
  5.    ClientLeft      =   60
  6.    ClientTop       =   345
  7.    ClientWidth     =   7335
  8.    LinkTopic       =   "Form1"
  9.    ScaleHeight     =   4200
  10.    ScaleWidth      =   7335
  11.    StartUpPosition =   3  'Windows Default
  12.    Begin VB.TextBox Txt 
  13.       Height          =   375
  14.       IMEMode         =   3  'DISABLE
  15.       Index           =   4
  16.       Left            =   3960
  17.       PasswordChar    =   "*"
  18.       TabIndex        =   12
  19.       Text            =   "Txt(4)"
  20.       Top             =   480
  21.       Width           =   1935
  22.    End
  23.    Begin VB.TextBox Txt 
  24.       Height          =   375
  25.       Index           =   3
  26.       Left            =   600
  27.       TabIndex        =   10
  28.       Text            =   "Txt(3)"
  29.       Top             =   480
  30.       Width           =   2415
  31.    End
  32.    Begin VB.TextBox Txt 
  33.       Height          =   855
  34.       Index           =   5
  35.       Left            =   0
  36.       MultiLine       =   -1  'True
  37.       TabIndex        =   8
  38.       Text            =   "fMain.frx":0000
  39.       Top             =   2760
  40.       Width           =   5895
  41.    End
  42.    Begin VB.TextBox Txt 
  43.       Height          =   375
  44.       Index           =   2
  45.       Left            =   2160
  46.       TabIndex        =   4
  47.       Text            =   "Txt(2)"
  48.       Top             =   1080
  49.       Width           =   3735
  50.    End
  51.    Begin VB.TextBox Txt 
  52.       Height          =   375
  53.       Index           =   1
  54.       Left            =   2160
  55.       TabIndex        =   3
  56.       Text            =   "Txt(1)"
  57.       Top             =   0
  58.       Width           =   3735
  59.    End
  60.    Begin VB.TextBox Txt 
  61.       Height          =   855
  62.       Index           =   0
  63.       Left            =   0
  64.       MultiLine       =   -1  'True
  65.       TabIndex        =   2
  66.       Text            =   "fMain.frx":0009
  67.       Top             =   1920
  68.       Width           =   5895
  69.    End
  70.    Begin VB.CommandButton cStop 
  71.       Caption         =   "Stop"
  72.       Height          =   375
  73.       Index           =   1
  74.       Left            =   2520
  75.       TabIndex        =   1
  76.       Top             =   3720
  77.       Width           =   735
  78.    End
  79.    Begin VB.CommandButton cStart 
  80.       Caption         =   "Start"
  81.       Height          =   375
  82.       Index           =   0
  83.       Left            =   960
  84.       TabIndex        =   0
  85.       Top             =   3720
  86.       Width           =   735
  87.    End
  88.    Begin VB.Label Lbl 
  89.       Caption         =   "Password:"
  90.       Height          =   375
  91.       Index           =   4
  92.       Left            =   3120
  93.       TabIndex        =   11
  94.       Top             =   480
  95.       Width           =   855
  96.    End
  97.    Begin VB.Label Lbl 
  98.       Caption         =   "UserID:"
  99.       Height          =   375
  100.       Index           =   3
  101.       Left            =   0
  102.       TabIndex        =   9
  103.       Top             =   480
  104.       Width           =   2175
  105.    End
  106.    Begin VB.Label Lbl 
  107.       Caption         =   "Process Files Like"
  108.       Height          =   375
  109.       Index           =   2
  110.       Left            =   0
  111.       TabIndex        =   7
  112.       Top             =   1080
  113.       Width           =   2175
  114.    End
  115.    Begin VB.Label Lbl 
  116.       Caption         =   "Web Service Address"
  117.       Height          =   375
  118.       Index           =   1
  119.       Left            =   0
  120.       TabIndex        =   6
  121.       Top             =   0
  122.       Width           =   2175
  123.    End
  124.    Begin VB.Label Lbl 
  125.       Caption         =   "File:"
  126.       Height          =   375
  127.       Index           =   0
  128.       Left            =   0
  129.       TabIndex        =   5
  130.       Top             =   1560
  131.       Width           =   4575
  132.    End
  133. End
  134. Attribute VB_Name = "fMain"
  135. Attribute VB_GlobalNameSpace = False
  136. Attribute VB_Creatable = False
  137. Attribute VB_PredeclaredId = True
  138. Attribute VB_Exposed = False
  139. Private WebAdr$
  140. Private FName$
  141. Private bUpdate As Boolean
  142. Private CurFName$
  143. Private IP$
  144. Private dStart As Date
  145. Private dFStart As Date
  146. Private lBytes As Long
  147. Private sBytes As Single
  148. Private sFiles As Long, sRecs As Long
  149. Private Stopit As Boolean
  150. Private XFRErr As Boolean
  151. Private SoapClnt As New SoapClient30
  152. Private UserID$, PW$
  153.  
  154. Private Sub StatusUpdate()
  155. Dim x$
  156. x$ = "Started: " + Format$(dStart) + vbCrLf
  157. x$ = x$ + "Files Transferred: " + Format$(sFiles)
  158. Txt(5) = x$
  159. Txt(5).Refresh
  160. End Sub
  161. Private Function MkName$(Mask$)
  162. Dim i As Integer
  163. Dim y$
  164. y$ = Date$ + Time$
  165. i = InStr(Mask$, ".")
  166. If i > 0 Then
  167.  MkName$ = Left$(Mask$, i - 1) + y$ + Mid$(Mask$, i)
  168. Else
  169.  MkName$ = Mask$ + y$
  170. End If
  171. End Function
  172.  
  173. Private Sub cStart_Click(Index As Integer)
  174. Dim SoapCls As New clsSoap
  175.  
  176. On Error GoTo estart
  177. sFiles = 0
  178. sRecs = 0
  179. Set SoapClnt = New SoapClient30
  180. Close #1
  181. Close #2
  182. Open App.Path + "\WebSvc.LOG" For Append As #2
  183. If Len(WebAdr$) = 0 Then Txt(1).SetFocus
  184. If Len(FName$) = 0 Then Txt(2).SetFocus
  185. If Len(UserID$) = 0 Then Txt(3).SetFocus
  186. If Len(PW$) = 0 Then Txt(4).SetFocus
  187. 'If fMain.ActiveControl.Caption <> "Start" Then Exit Sub
  188. Txt(0) = ""
  189. If Len(WebAdr$) = 0 Or Len(FName$) = 0 Or Len(UserID$) = 0 Or Len(PW$) = 0 Then
  190.  Txt(0) = "Missing Some Data field needed to Start" + vbCrLf + "Enter Missing Data and Press Start Again"
  191.  Exit Sub
  192. End If
  193.  
  194. Txt(0) = ""
  195. Print #2, ""
  196. Print #2, ""
  197. Print #2, "Started: " + Format$(Now) + ", attempting Web Service Connect to " + WebAdr$
  198. Print #2, "Using Logon: " + UserID$ + " and Password: " + PW$
  199. SoapInit
  200. If InStr(Txt(0), " Not ") Then
  201.  Print #2, Txt(0)
  202.  Print #2, ""
  203.  Print #2, "Stopped for connection error at: " + Format$(Now)
  204. Exit Sub
  205. End If
  206. Process
  207. Close #1
  208. 'Close #2
  209. dStart = Now
  210. dFStart = Now
  211. lBytes = 0
  212. estart:
  213. End Sub
  214. Private Sub Process()
  215. Dim Path$, UseFile$, MaskFile$, y$, Fil$, Rslt$
  216.  
  217.   
  218.   MaskFile$ = Txt(2).Text
  219.   UseFile$ = MaskFile$
  220.   Path$ = MaskFile$
  221.   While InStr("\:", Right$(Path$, 1)) = 0 And Len(Path$) > 0
  222.    Path$ = Left$(Path$, Len(Path$) - 1)
  223.   Wend
  224.   If Len(Dir$(MaskFile$)) = 0 And (InStr(MaskFile$, "*") + InStr(MaskFile$, "?") = 0) Then
  225.       GoTo Xit
  226.   Else
  227.     UseFile$ = Dir$(MaskFile$)
  228.     Txt(0).Text = "Waiting for " + MaskFile$
  229.   End If
  230.   While Not Stopit
  231.     While Len(UseFile$) = 0
  232.      Txt(0).Text = "Waiting for " + MaskFile$
  233.      DoEvents
  234.      If Stopit Then GoTo Xit  'this assures a log file is created
  235.      UseFile$ = Dir$(MaskFile$)
  236.      DoEvents
  237.     Wend
  238.     locfile$ = Path$ + UseFile$
  239.     XFRErr = False
  240.     FTPFile$ = UseFile$
  241.     Txt(0).Text = "Sending " + locfile$
  242.     Print #2, Txt(0).Text
  243.     Close #1
  244.     Open locfile$ For Input As #1
  245.     sRecs = 0
  246.     Do While Not EOF(1)
  247.      Line Input #1, Fil$
  248.      Rslt$ = SendData(Fil$)
  249.      DoEvents
  250.      If XFRErr Then Exit Do
  251.      sRecs = sRecs + 1
  252.     Loop
  253.     Close #1
  254.     If Not xrferr Then sFiles = sFiles + 1
  255.     StatusUpdate
  256.     fMain.Refresh
  257.     If Not XFRErr Then
  258.       y$ = UseFile$        'make new file name in y$
  259.       While Right$(y$, 1) <> "." And Len(y$) > 0
  260.        y$ = Left$(y$, Len(y$) - 1)
  261.       Wend
  262.       y$ = "Done-" + Format$(Now, "Medium Date") + "-" + Time$ + "-" + y$ + "DUN"
  263.       y$ = SubTran$(y$, ":", "-")
  264.       y$ = SubTran$(y$, "/", "-")
  265.       If Len(Dir$(Path$ + y$)) > 0 Then Kill Path$ + y$
  266.       Name Path$ + UseFile$ As Path$ + y$ 'prevent from being read again
  267.       Print #2, Format$(Now) + ": Processed " + Format$(sRecs) + " From " + Path$ + UseFile$
  268.     Else
  269.       Print #2, Format$(Now) + ": Error Processing " + Path$ + UseFile$
  270.       GoTo Xit
  271.     End If
  272.     UseFile$ = ""
  273.     fMain.Refresh
  274.   Wend
  275. 'Close #2
  276. Xit:
  277.  cStop_Click (0)
  278.  End
  279. End Sub
  280.  
  281. Private Sub cStop_Click(Index As Integer)
  282.  Dim x$
  283.  Close #2
  284.  Open App.Path + "\WebSvc.LOG" For Append As #2
  285.  Stopit = True
  286.  If Index = 1 Then
  287.   Print #2, "Stopped by Stop Button at: " + Format$(Now)
  288.  Else
  289.   Print #2, "Stopped by Program Logic at: " + Format$(Now)
  290.  End If
  291.  If bUpdate Then
  292.   x$ = App.Path + "\" + "WebSvc.Set"
  293.   If Len(Dir$(x$)) Then Kill x$
  294.   Close #1
  295.   Open x$ For Output As #1
  296.   Print #1, WebAdr$
  297.   Print #1, UserID$
  298.   Print #1, PW$
  299.   Print #1, FName$
  300.   Close #1
  301.  End If
  302.  End
  303.  
  304. End Sub
  305.  
  306. Private Sub Form_Load()
  307. Dim x$
  308.  On Error Resume Next
  309.  dStart = Now
  310.  sBytes = 0
  311.  sFiles = 0
  312.  bUpdate = False
  313.  Txt(0) = ""
  314.  x$ = App.Path + "\" + "WebSvc.Set"
  315.  If Len(Dir$(x$)) Then
  316.   Open x$ For Input As #1
  317.   Line Input #1, WebAdr$
  318.   Txt(1) = WebAdr$
  319.   Line Input #1, UserID$
  320.   Txt(3) = UserID$
  321.   Line Input #1, PW$
  322.   Txt(4) = PW$
  323.   Line Input #1, FName$
  324.   Txt(2) = FName$
  325.   Close #1
  326.  End If
  327.  StatusUpdate
  328.  fMain.Refresh
  329. End Sub
  330.  
  331. Private Sub Form_Resize()
  332. Txt(1).Move Txt(1).Left, Txt(1).Top, Me.Width - Txt(1).Left - 100
  333. Txt(2).Move Txt(2).Left, Txt(2).Top, Me.Width - Txt(2).Left - 100
  334. cStart(0).Move cStart(0).Left, Me.Height - cStart(0).Height - 650
  335. cStop(1).Move cStop(1).Left, cStart(0).Top
  336. Txt(0).Move Txt(0).Left, Txt(0).Top, Me.Width - Txt(0).Left - 200, (Me.Height - Txt(0).Top - 800 - cStart(0).Height) / 2
  337. Txt(5).Move Txt(5).Left, Txt(0).Top + Txt(0).Height, Txt(0).Width, Txt(0).Height
  338. End Sub
  339.  
  340. Private Sub Form_Unload(Cancel As Integer)
  341.  cStop_Click (Cancel)
  342. End Sub
  343.  
  344. Private Sub Txt_LostFocus(Index As Integer)
  345. Select Case Index
  346.  Case 1
  347.   If WebAdr$ <> Txt(1) Then
  348.    WebAdr$ = Txt(1)
  349.    bUpdate = True
  350.   End If
  351.  Case 2
  352.   If FName$ <> Txt(2) Then
  353.    FName$ = Txt(2)
  354.    bUpdate = True
  355.   End If
  356.  Case 3
  357.   If UserID$ <> Txt(3) Then
  358.    UserID$ = Txt(3)
  359.    bUpdate = True
  360.   End If
  361.  Case 4
  362.   If PW$ <> Txt(4) Then
  363.    PW$ = Txt(4)
  364.    bUpdate = True
  365.   End If
  366. End Select
  367. End Sub
  368. Public Function SubTran$(Inst$, Lookfor$, ByVal Change2$)
  369.  Dim i As Long, j As Long
  370.  Dim InString$
  371.  InString$ = Inst$
  372.  j = 1
  373.  i = InStr(j, InString$, Lookfor$)
  374.  While i > 0
  375.    InString$ = Left$(InString$, i - 1) + Change2$ + Mid$(InString$, i + Len(Lookfor$))
  376.    j = i + Len(Change2$)
  377.    i = InStr(j, InString$, Lookfor$)
  378.  Wend
  379.  SubTran$ = InString$
  380. End Function
  381. Private Function SendData$(ByVal MedData As String)
  382.  
  383.  
  384.     On Error Resume Next
  385.     
  386.     XFRErr = False
  387.  
  388.     SendData$ = UCase$(SoapClnt.PatientUpdate2(MedData))
  389.     If Err.Number <> 0 Then
  390.      Txt(0) = "Error Transmitting Record!" + vbCrLf + Err.Description + vbCrLf + MedData
  391.      Print #2, Txt(0)
  392.      XFRErr = True
  393.     ElseIf SendData$ = "FAIL" Then
  394.      Txt(0) = "Record Transmitted but Not Acceptable to ProCareRX!" + vbCrLf + MedData
  395.      Print #2, Txt(0)
  396.      XFRErr = True
  397.     ElseIf SendData$ = "PASS" Then
  398.      Txt(0) = "Record " + Format$(sRecs) + " Accepted by ProCareRX!"
  399.      Txt(0).Refresh
  400.     End If
  401.     
  402. End Function
  403.  
  404. Private Sub SoapInit()
  405. Dim Auth$, Base64Auth$
  406. Dim SoapCls As New clsSoap
  407.  
  408. On Error GoTo SCErr
  409.  
  410.  Txt(0) = ""
  411.  Auth$ = LCase$(WebAdr$ + "?wsdl")
  412.  Auth$ = SubTran$(Auth$, "https://", "https://" + UserID$ + ":" + PW$ + "@")
  413.     Print #2, "Using Connect URL: " + Auth$
  414.  
  415.     SoapClnt.MSSoapInit Auth$
  416.     
  417.     SoapCls.NameSpace = "PutPBM"
  418.     SoapCls.SetLogin UserID$, PW$
  419.     Set SoapClnt.HeaderHandler = SoapCls
  420.  
  421.     Print #2, "Connection SUccessful at " + Format$(Now)
  422.  
  423. Exit Sub
  424. SCErr:
  425.     
  426.     If Err.Number <> 0 Then Txt(0) = "Soap Connection Not Established!" + vbCrLf + Err.Description
  427.     'SOAPClnt.ConnectorProperty("AuthUser") = UserID$
  428.     'SOAPClnt.ConnectorProperty("AuthPassword") = PW$
  429.      
  430. End Sub
  431.  
  432.  
  433.