Visual Basic - Convertir formulario en pdf con vb 6.0

Val: 7

Convertir formulario en pdf con vb 6.0

Publicado por Javier (4 intervenciones) el 04/09/2017 01:24:11

buenas tardes amigos necesito de su enorme ayuda porque estoy tratando de transformar un formulario con sus datos en pdf y no se como hacerlo... he revisado algunos articulo donde hablan de usar las impresoras virtuales pero no entendi como trabajarlas veo que mencionan mucho pdfcreater pero como se llama el componente ocx o dll para agregarlo en visaul basic y poderlo trabajar?, de hecho revise el ejemplo que trae por defecto el pdfcreater pero al ejecutarlo desde visaul basic 6.0 genera un error... consegui otro componente pdfcom.dll este lo agregue por la ventana de componentes de visaul basic peroo no se como crear el pdf desde ahi.... bueno aqui les dejo el codigo de mi formulario... les agradezco su gran ayuda y orientacion...gracias de antemano amigos....

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42

43

44

45

46

47

48

49

50

51

52

53

54

55

56

57

58

59

60

61

62

63

64

65

66

67

68

69

70

71

72

73

74

75

76

77

78

79

80

81

82

83

84

85

86

87

88

89

90

91

92

93

94

95

96

97

98

99

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

Public valor, cad_num_presupuesto, cad_id, aux_rif, aux_id_insum, aux_id_present, aux_num_presup, aux_descrip_insum, id_presup As String

Public i, j As Integer

Public encontrado As Boolean

Private Sub btn_actualizar_Click()

If MsgBox("desea actualizar el contenido", vbYesNo, "Actualizar") = 6 Then

    i = 1

    aux_num_presup = Trim(num_presup.Caption)

    Set rs_p = New ADODB.Recordset

      SQL = "select * from presupuesto where num_presupuesto like '%" & Trim(aux_num_presup) & "%' order by id"

      rs_p.Open SQL, db, , , adCmdText

    If Not rs_p.EOF Then

      rs_p.MoveFirst

      While Not rs_p.EOF

        aux_descrip_insum = Trim(MSFlexGrid4.TextMatrix(i, 2))

        Set rs_i = New ADODB.Recordset

          SQL = "select * from insumo where descripcion like '%" & Trim(aux_descrip_insum) & "%' order by id_insumo"

          rs_i.Open SQL, db, , , adCmdText

        aux_id_insum = Trim(rs_i![id_insumo])

        aux_id_presup = Trim(rs_p![id])

        If MSFlexGrid4.TextMatrix(i, 2) <> "" Then

          'If aux_num_presup = Trim(rs_p![num_presupuesto]) Then

            SQL = "UPDATE presupuesto SET fecha_emision='" & Trim(fech_elab.Text) & "', fecha_vencimiento='" & Trim(fech_vencim.Text) & "', responsable='" & Trim(respons.Text) & "', telefonos='" & Trim(telf_contac.Text) & "', oficina='" & Trim(ofici.Text) & "', celular='" & Trim(telf_cel.Text) & "', num_circuito='" & Trim(num_circui.Text) & "'," _

              & "id_insumo='" & Trim(aux_id_insum) & "', cantidad='" & Trim(MSFlexGrid4.TextMatrix(i, 4)) & "', precio='" & Trim(MSFlexGrid4.TextMatrix(i, 5)) & "', rif='" & Trim(rif.Text) & "' where id like '%" & Trim(aux_id_presup) & "%'"

              db.Execute SQL, sopt

          'End If

        End If

        i = i + 1

        rs_p.MoveNext

      Wend

    End If

  Set rs_c = New ADODB.Recordset

    SQL = "UPDATE cliente SET razon_social='" & Trim(razon_social.Text) & "', rif='" & Trim(rif.Text) & "', direccion='" & Trim(direcc_clien.Text) & "', contacto='" & Trim(contac.Text) & "', telefonos='" & Trim(telf_clien.Text) & "', correo_electronico='" & Trim(email_clien.Text) & "' where rif like '%" & Trim(rif.Text) & "%' "

    db.Execute SQL, sopt

  rs_i.Close

  rs_p.Close

  MsgBox "Actualización Exitosa...", vbInformation, "REGISTRO DATOS ESTABLECIMIENTO"

End If

Call limpiar

End Sub

Private Sub btn_buscar_Click()

Dim val As String

val = InputBox("INGRESE NUMERO DE PRESUPUESTO...            Ejemplo:    E-CDR-LAR-0507-17", "BUSQUEDA PRESUPUESTO")

If val <> "" Then

  Set rs_p = New ADODB.Recordset

    SQL = "select * from presupuesto where num_presupuesto='" & Trim(val) & "'"

    rs_p.Open SQL, db, , , adCmdText

    If Not rs_p.EOF Then

      rs_p.MoveFirst

      i = 1

      While Not rs_p.EOF

        If Trim(rs_p![num_presupuesto]) = val Then

          num_presup.Caption = Trim(rs_p![num_presupuesto])

          fech_elab.Text = Trim(rs_p![fecha_emision])

          fech_vencim.Text = Trim(rs_p![fecha_vencimiento])

          respons.Text = Trim(rs_p![responsable])

          telf_contac.Text = Trim(rs_p![telefonos])

          ofici.Text = Trim(rs_p![oficina])

          telf_cel.Text = Trim(rs_p![celular])

          num_circui.Text = Trim(rs_p![num_circuito])

          rif.Text = Trim(rs_p![rif])

          If IsNull(Trim(rs_p![cantidad])) Then

            MSFlexGrid4.TextMatrix(i, 4) = ""

          Else

            MSFlexGrid4.TextMatrix(i, 4) = Trim(rs_p![cantidad])

          End If

          If IsNull(Trim(rs_p![precio])) Then

            MSFlexGrid4.TextMatrix(i, 5) = ""

          Else

            MSFlexGrid4.TextMatrix(i, 5) = Trim(rs_p![precio])

          End If

          aux_rif = Trim(rs_p![rif])

          aux_id_insum = Trim(rs_p![id_insumo])

          Set rs_c = New ADODB.Recordset

            SQL = "select * from cliente where rif like '%" & aux_rif & "%' order by rif"

          rs_c.Open SQL, db, , , adCmdText

          If Not rs_c.EOF Then

            razon_social.Text = Trim(rs_c![razon_social])

          Else

            razon_social.Text = ""

          End If

          If Not rs_c.EOF Then

            direcc_clien.Text = Trim(rs_c![direccion])

          Else

            direcc_clien.Text = ""

          End If

          If Not rs_c.EOF Then

            contac = Trim(rs_c![contacto])

          Else

            contac = ""

          End If

          If Not rs_c.EOF Then

            telf_clien = Trim(rs_c![telefonos])

          Else

            telf_clien = ""

          End If

          If Not rs_c.EOF Then

            email_clien = Trim(rs_c![correo_electronico])

          Else

            email_clien = ""

          End If

          Set rs_i = New ADODB.Recordset

            SQL = "select * from insumo order by id_insumo"

          rs_i.Open SQL, db, , , adCmdText

          rs_i.MoveFirst

          If Not rs_i.EOF Then

            While Not rs_i.EOF

              If aux_id_insum = Trim(rs_i![id_insumo]) Then

                MSFlexGrid4.TextMatrix(i, 2) = Trim(rs_i![descripcion])

                aux_id_present = Trim(rs_i![id_presentacion])

                Set rs_d = New ADODB.Recordset

                  SQL = "select * from presentacion"

                rs_d.Open SQL, db, , , adCmdText

                rs_d.MoveFirst

                If Not rs_d.EOF Then

                  While Not rs_d.EOF

                    If aux_id_present = Trim(rs_d![id_presentacion]) Then

                      MSFlexGrid4.TextMatrix(i, 3) = Trim(rs_d![nombre_presentacion])

                    End If

                    rs_d.MoveNext

                  Wend

                End If

              End If

              rs_i.MoveNext

            Wend

          End If

          i = i + 1

          rs_p.MoveNext

        End If

      Wend

      rs_d.Close

      rs_p.Close

      rs_c.Close

      rs_i.Close

    End If

Else

  MsgBox "DEBE ESCRIBIR UN NUMERO DE PRESUPUESTO", vbExclamation

End If

End Sub

Private Sub btn_cancelar_Click()

Call limpiar

End Sub

Private Sub btn_guardar_Click()

Dim aux_i As String

If MsgBox("desea guardar el contenido", vbYesNo + vbQuestion, "Inclusión") = 6 Then

  Set rs_c = New ADODB.Recordset

    SQL = "select * from cliente where rif not like '%" & Trim(rif.Text) & "%' order by rif"

    rs_c.Open SQL, db, , , adCmdText

    SQL = "insert into cliente(id,razon_social,rif,direccion,contacto,telefonos,correo_electronico)" _

      & "values('" & Trim(cad_id) & "','" & Trim(razon_social.Text) & "','" & Trim(rif.Text) & "','" & Trim(direcc_clien.Text) & "','" & Trim(contac.Text) & "','" & Trim(telf_clien.Text) & "','" & Trim(email_clien.Text) & "')"

      db.Execute SQL, sopt

    rs_c.Close

  For i = 1 To (MSFlexGrid4.Rows - 1)

    If MSFlexGrid4.TextMatrix(i, 2) <> "" Then

      Set rs_i = New ADODB.Recordset

        SQL = "select * from insumo order by id_insumo"

      rs_i.Open SQL, db, , , adCmdText

      If Not rs_i.EOF Then

        rs_i.MoveFirst

        encontrado = False

        While Not rs_i.EOF And Not encontrado

          If Trim(MSFlexGrid4.TextMatrix(i, 2)) = Trim(rs_i![descripcion]) Then

            aux_i = Trim(rs_i![id_insumo])

            SQL = "insert into presupuesto(num_presupuesto,fecha_emision,fecha_vencimiento,responsable,telefonos,oficina,celular,num_circuito,id_insumo,cantidad,precio,id,rif)" _

                & "values('" & Trim(num_presup.Caption) & "','" & Trim(fech_elab.Text) & "','" & Trim(fech_vencim.Text) & "','" & Trim(respons.Text) & "','" & Trim(telf_contac.Text) & "','" & Trim(ofici.Text) & "','" & Trim(telf_cel.Text) & "','" & Trim(num_circui.Text) & "','" & Trim(aux_i) & "','" & Trim(MSFlexGrid4.TextMatrix(i, 4)) & "','" & Trim(MSFlexGrid4.TextMatrix(i, 5)) & "','" & Trim(cad_id) & "','" & Trim(rif.Text) & "')"

            db.Execute SQL, sopt

            encontrado = True

          End If

          rs_i.MoveNext

        Wend

        rs_i.Close

      End If

    End If

  Next i

  MsgBox "Inclusion Exitosa...", vbInformation, "REGISTRO PRESUPUESTO"

End If

Call limpiar

End Sub

Private Sub btn_salir_Click()

Unload Me

End Sub

Private Sub cmb_descrip_Click()

valor = cmb_descrip.Text

Set rs_d = New ADODB.Recordset

 SQL = "select * from insumo order by id_insumo"

 rs_d.Open SQL, db, , , adCmdText

 If Not rs_d.EOF Then

   rs_d.MoveFirst

   While Not rs_d.EOF

   If Trim(valor) = Trim(rs_d![descripcion]) Then

     aux_d = Trim(rs_d![id_presentacion])

   End If

   rs_d.MoveNext

   Wend

 End If

 MSFlexGrid4.Text = cmb_descrip.Text

 cmb_descrip.Visible = False

 cmb_present.Clear

 Set rs_p = New ADODB.Recordset

    SQL = "select * from presentacion order by id_presentacion"

    rs_p.Open SQL, db, , , adCmdText

    If Not rs_p.EOF Then

      rs_p.MoveFirst

      While Not rs_p.EOF

        If Trim(rs_p![id_presentacion]) = Trim(aux_d) Then

          cmb_present.AddItem Trim(rs_p![nombre_presentacion])

        Else

          cmb_present.Text = " "

        End If

        rs_p.MoveNext

      Wend

    End If

rs_d.Close

rs_p.Close

End Sub

Private Sub cmb_present_Click()

MSFlexGrid4.Text = cmb_present.Text

cmb_present.Visible = False

End Sub

Private Sub Form_Load()

Set db = New ADODB.Connection

 db.Open "PROVIDER=MSDASQL;dsn=PostgreSQL30;uid=postgres;pwd=987654;database=Presupuesto_RedVen;"

 sopt = dbsqlPassTrough

cmb_descrip.Visible = False

Set rs_d = New ADODB.Recordset

 SQL = "select * from insumo order by id_insumo"

 rs_d.Open SQL, db, , , adCmdText

 rs_d.MoveFirst

 If Not rs_d.EOF Then

   While Not rs_d.EOF

     cmb_descrip.AddItem Trim(rs_d![descripcion])

     rs_d.MoveNext

   Wend

 End If

rs_d.Close

cmb_present.Visible = False

End Sub

Private Sub Form_Unload(Cancel As Integer)

db.Close

End Sub

Private Sub MSFlexGrid4_Click()

If cmb_descrip.Visible = True Then

  cmb_descrip.Visible = False

End If

If cmb_present.Visible = True Then

  cmb_present.Visible = False

End If

If MSFlexGrid4.Col = 2 Then

  cmb_descrip.Top = MSFlexGrid4.Top + MSFlexGrid4.CellTop

  cmb_descrip.Width = MSFlexGrid4.CellWidth

  cmb_descrip.Left = MSFlexGrid4.CellLeft + MSFlexGrid4.Left

  cmb_descrip.Visible = True

End If

If MSFlexGrid4.Col = 3 Then

  cmb_present.Top = MSFlexGrid4.Top + MSFlexGrid4.CellTop

  cmb_present.Width = MSFlexGrid4.CellWidth

  cmb_present.Left = MSFlexGrid4.CellLeft + MSFlexGrid4.Left

  cmb_present.Visible = True

End If

End Sub

Private Sub MSFlexGrid4_KeyPress(KeyAscii As Integer)

Dim T As String

T = MSFlexGrid4.Text

If KeyAscii = 8 Then

  If Len(T) > 0 Then T = Left(T, Len(T) - 1)

  Else

    T = T + Chr(KeyAscii)

  End If

  MSFlexGrid4.Text = T

End Sub

Private Sub VScroll1_Change()

    SSTab1.Top = -VScroll1.Value

End Sub

Private Sub limpiar()

razon_social.Text = ""

rif.Text = ""

direcc_clien.Text = ""

contac.Text = ""

telf_clien.Text = ""

email_clien.Text = ""

fech_elab.Text = ""

fech_vencim.Text = ""

respons.Text = ""

telf_contac.Text = ""

ofici.Text = ""

telf_cel.Text = ""

num_circui.Text = ""

MSFlexGrid4.Clear

End Sub

Valora esta pregunta

Me gusta: Está pregunta es útil y esta clara

No me gusta: Está pregunta no esta clara o no es útil

0

Responder

Pos: 2

Val: 1.259

Convertir formulario en pdf con vb 6.0

Publicado por Antoni Masana (566 intervenciones) el 04/09/2017 10:11:00

En las últimas versiones de Windows y Office vienen con una impresora virtual que genera ficheros PDF.
Para solucionar el problema tienes que hacer igual que si la impresión fuese en papel pero seleccionando la impresora PDFCreator, el nombre podría ser diferente según la versión.

Este codigo lo uso para que el programa busque la impresora PDF y si no existe da un aviso.

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

Dim Prt As Printer, PDF As Boolean, PRN_Actual As String

...

PRN_Actual = Printer.DeviceName

If Out_PDF.Value Then    ' --- Tengo la opción de impresora o PDF

   PDF = False

   For Each Prt In Printers

       If InStr(Prt.DeviceName, "PDF") > 0 Then Set Printer = Prt: PDF = True

   Next

   If Not PDF Then Call Aviso: Exit  Sub

End if

...

Printer.EndDoc

For Each Prt In Printers

    If Prt.DeviceName = PRN_Actual Then Set Printer = Prt

Next

Guarda la impresora por defecto.
Busca alguna impresora que en el nombre tenga el texto PDF y la establece como predeterminada
Si no la encuentra Sale.
Al finalizar la impresión restaura la impresora por defecto.

Saludos.
\\//_

Valora esta respuesta