Help-me

[POLIVEIRA]

Galera,

não sei quase que nada de vba e preciso muito da ajuda de voces.

tenho uma macro que ao termino do preenchimento de um formulario ela gera um documento em word, so que este documento esta saindo desconfigurado, as perguntas umas saem em negrito e outras não e assim vai.

Ao termino ele também cria este documento por da um erra "460" e aponta para o local onde esta endereçado o cod.

podem me ajudar por fvr.

Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function CloseClipboard Lib "user32" () As Long

Private Declare Function EmptyClipboard Lib "user32" () As Long

Private wsSuporte As Worksheet

Dim GetUserN

Dim ObjNetwork

'Declarações

Dim appWord As Variant

Dim doc As Variant

Dim stCabc As String

Dim prg As Variant

Dim rng As Variant

Sub CriarDocumento()

Set wsSuporte = ThisWorkbook.Worksheets("SUPORTE")

'limpar area de transferência

Call JustEmptyClipboard

'Declarações

Dim stPrg1 As String

'INICIO SELEÇÃO

stPrg1 = wsSuporte.Range("A9").Text '---> "G9"

Dim myRang As String

Dim stNome As String

Dim stRcl As String

Dim intLin As Integer

Dim intLimite As Integer

stNome = Worksheets("SUPORTE").Range("A9").Text ' -> ("C19")

'A Aplicação é criada aqui:

Set appWord = CreateObject("Word.Application")

'A linha abaixo é importante: você deve querer que

'sua aplicação seja visível na maioria das vezes

appWord.Visible = True

'Note que, na linha abaixo, foi adicionado um Documento

'dentro da Aplicação appWord:

Set doc = appWord.Documents.Add

'Da mesma forma, é atribuído ao Parágrafo prg o primeiro

'parágrafo existente do Documento doc.

Set prg = doc.Paragraphs(1)

'Dimencionar Margens da pagina

doc.PageSetup.TopMargin = Application.CentimetersToPoints(2.5)

doc.PageSetup.BottomMargin = Application.CentimetersToPoints(2.5)

doc.PageSetup.LeftMargin = Application.CentimetersToPoints(3)

doc.PageSetup.RightMargin = Application.CentimetersToPoints(3)

doc.PageSetup.HeaderDistance = Application.CentimetersToPoints(1.25)

doc.PageSetup.FooterDistance = Application.CentimetersToPoints(1.25)

'Abre Cabeçalho

doc.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader

'Alinha logo ao centro

doc.ActiveWindow.ActivePane.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter

'Formata Fonte

doc.ActiveWindow.ActivePane.Selection.Font.Size = 10

doc.ActiveWindow.ActivePane.Selection.Font.Bold = wdToggle

doc.ActiveWindow.ActivePane.Selection.Font.Italic = wdToggle

doc.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

doc.ActiveWindow.View.DisplayPageBoundaries = False

'Insere texto 1º paragrafo

doc.ActiveWindow.Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify

prg.Range.Text = stPrg1

doc.ActiveWindow.Selection.MoveDown Unit:=wdScreen

doc.ActiveWindow.Selection.EndKey Unit:=wdLine

Set rng = prg.Range

With rng.Font

.Bold = False

.Name = "Arial"

.Size = 12

.Color = wdColorAutomatic 'TESTE DE TROCA DE COR .Color = wdColorDarkTeal

End With

If frmDadosFormulario.optCFolha.Value = True Then

intLimite = 325 ' intLimite = 325

Else

intLimite = 118 'intLimite = 118

End If

For intLin = 9 To intLimite

stPrg1 = wsSuporte.Range("A" & intLin).Text ' -----> "G"

If stPrg1 = "Em Branco" Then

doc.ActiveWindow.Selection.TypeParagraph

Else

If intLin > 9 Then

doc.ActiveWindow.Selection.TypeParagraph

doc.ActiveWindow.Selection.Range.Text = stPrg1

doc.ActiveWindow.Selection.MoveDown Unit:=wdScreen

doc.ActiveWindow.Selection.EndKey Unit:=wdLine

End If

End If

Next

Call DestaqueEmNegrito

Set ObjNetwork = CreateObject("WScript.Network")

GetUserN = ObjNetwork.UserName

UsuarioRede = GetUserN

Dim stNomeArq As String

Dim Resposta As Integer

Resposta = MsgBox("Verique o conteudo da carta, se estiver de acordo clique em Sim", vbExclamation + vbYesNo, "ATENÇÃO!")

If Resposta <> 6 Then

MsgBox "O documento não será salvo, você poderá reeditar no auto carta ou no próprio documento", vbInformation, "Atenção!"

Exit Sub

Else

stNomeArq = InputBox("O documento será salvo em sua área de trabalho, Insira o nome do documento!")

''Salvar Como':

doc.SaveAs Filename:="C:\Documents and Settings\" & UsuarioRede & "\Desktop\" & stNomeArq & ".doc", FileFormat:=wdFormatXMLDocument

'FileFormat:=wdFormatXMLDocument significa que o arquivo será salvo com a

'extensão .doc, ou seja, Documento do Word 2003.

'Agora, deseja-se sair da Aplicação. Observe que o método é executado

'no nível da Aplicação, finalizando a Aplicação e todos os objetos

'criados por ela:

appWord.Quit

End If

'Apenas para limpar memória

Set appWord = Nothing

Set doc = Nothing

Set prg = Nothing

Set ObjNetwork = Nothing

End Sub

Sub JustEmptyClipboard()

OpenClipboard (0)

EmptyClipboard

CloseClipboard

End Sub

Sub LimparCarta()

Worksheets("SUPORTE").Range("C14:C42").ClearContents

Worksheets("SUPORTE").Range("C49:C58").ClearContents

Worksheets("SUPORTE").Range("C61:C67").ClearContents

Worksheets("SUPORTE").Range("C70:C76").ClearContents

Worksheets("SUPORTE").Range("C79:C82").ClearContents

Worksheets("SUPORTE").Range("C85:C109").ClearContents

Worksheets("SUPORTE").Range("C112:C121").ClearContents

Worksheets("SUPORTE").Range("C124:C129").ClearContents

Worksheets("SUPORTE").Range("C132:C148").ClearContents

Worksheets("SUPORTE").Range("C151:C162").ClearContents

Worksheets("SUPORTE").Range("C171:C184").ClearContents

Worksheets("SUPORTE").Range("C187:C198").ClearContents

Worksheets("SUPORTE").Range("C201:C212").ClearContents

Worksheets("SUPORTE").Range("C215:C219").ClearContents

Worksheets("SUPORTE").Range("C222:C231").ClearContents

Worksheets("SUPORTE").Range("C234:C242").ClearContents

Worksheets("SUPORTE").Range("C247:C254").ClearContents

Worksheets("SUPORTE").Range("C257:C270").ClearContents

Worksheets("SUPORTE").Range("C273:C277").ClearContents

Worksheets("SUPORTE").Range("C280:C292").ClearContents

Worksheets("SUPORTE").Range("C299:C310").ClearContents

Worksheets("SUPORTE").Range("C313:C316").ClearContents

End Sub

Sub DestaqueEmNegrito()

Set wsSuporte = ThisWorkbook.Worksheets("SUPORTE")

Dim strNgrt As String

Dim intCel As Integer

For intCel = 1 To 325 '-> For intCel = 1 To 325

strNgrt = wsSuporte.Range("Q" & intCel).Text ' -> strNgrt = wsSuporte.Range("Q" & intCel).Text

doc.ActiveWindow.Selection.Find.ClearFormatting

With doc.ActiveWindow.Selection.Find

.Text = strNgrt

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindContinue

End With

doc.ActiveWindow.Selection.Find.Execute

doc.ActiveWindow.Selection.Font.Bold = True

If intCel > 2 And intCel < 19 Then '-------> If intCel > 2 And intCel < 19 Then

doc.ActiveWindow.Selection.Font.Underline = wdUnderlineSingle

End If

Next

intCel = 0

For intCel = 1 To 22 '-> For intCel = 1 To 12

strNgrt = wsSuporte.Range("R" & intCel).Text '-> strNgrt = wsSuporte.Range("R" & intCel).Text

doc.ActiveWindow.Selection.Find.ClearFormatting

With doc.ActiveWindow.Selection.Find

.Text = strNgrt

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindContinue

End With

doc.ActiveWindow.Selection.Find.Execute

doc.ActiveWindow.Selection.Font.Underline = wdUnderlineSingle

Next

intCel = 0

For intCel = 1 To 22 ' -> For intCel = 1 To 12

strNgrt = wsSuporte.Range("S" & intCel).Text ' -> strNgrt = wsSuporte.Range("S" & intCel).Text

doc.ActiveWindow.Selection.Find.ClearFormatting

With doc.ActiveWindow.Selection.Find

.Text = strNgrt

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindContinue

End With

doc.ActiveWindow.Selection.Find.Execute

doc.ActiveWindow.Selection.Font.Underline = wdUnderlineNone

doc.ActiveWindow.Selection.Font.Color = 16724787

Next

'---Centralizar

If frmDadosFormulario.optCFolha.Value = True Then

intCel = 0

For intCel = 1 To 3

strNgrt = wsSuporte.Range("Y" & intCel).Text ' -> strNgrt = wsSuporte.Range("Y" & intCel).Text

doc.ActiveWindow.Selection.Find.ClearFormatting

With doc.ActiveWindow.Selection.Find

.Text = strNgrt

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindContinue

End With

doc.ActiveWindow.Selection.Find.Execute

doc.ActiveWindow.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter

If strNgrt = "DADOS CLIENTE E PROCESSO" Then

doc.ActiveWindow.Selection.ParagraphFormat.SpaceBefore = 12

doc.ActiveWindow.Selection.ParagraphFormat.SpaceAfter = 3

End If

Next

Else

strNgrt = wsSuporte.Range("Y3").Text '-> strNgrt = wsSuporte.Range("Y3").Text

doc.ActiveWindow.Selection.Find.ClearFormatting

With doc.ActiveWindow.Selection.Find

.Text = strNgrt

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindContinue

End With

doc.ActiveWindow.Selection.Find.Execute

doc.ActiveWindow.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter

End If

End Sub

Sub Desproteger()

Worksheets("SUPORTE").Visible = xlSheetVisible

End Sub

Sub Form()

fmrBusca.Show

End Sub