VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmConv
BorderStyle = 1 'Fixed Single
Caption = "Convert xlsToHtml"
ClientHeight = 1320
ClientLeft = 45
ClientTop = 330
ClientWidth = 5205
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
Picture = "frmConv.frx":0000
ScaleHeight = 1320
ScaleWidth = 5205
StartUpPosition = 2 'CenterScreen
Begin VB.CommandButton cmdConvert
Caption = "&Convert"
Height = 360
Left = 3585
TabIndex = 4
Top = 900
Width = 1590
End
Begin VB.TextBox txtRange
Height = 315
Left = 1770
TabIndex = 3
Text = "A1:B2"
Top = 525
Width = 3390
End
Begin MSComDlg.CommonDialog CDiag
Left = 2850
Top = 2115
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton Command1
Caption = "&Save as..."
Height = 360
Index = 1
Left = 1785
TabIndex = 1
Top = 90
Width = 1590
End
Begin VB.CommandButton Command1
Caption = "&XLS source..."
Height = 360
Index = 0
Left = 120
TabIndex = 0
Top = 90
Width = 1590
End
Begin VB.Label Label1
Appearance = 0 'Flat
AutoSize = -1 'True
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "&Type a valid range:"
ForeColor = &H80000008&
Height = 195
Left = 90
TabIndex = 2
Top = 600
Width = 1365
End
End
Attribute VB_Name = "frmConv"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' Set a reference to Microsoft Excel object library
' throghout Menu project, references...
Dim XLSFile As String
Dim HTMLFile As String
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim sh As Excel.Worksheet
Sub ConvertXLSToHtml(XFilename As String, HFilename As String, ValRng As String)
' This routine could be modify to create a more
' nice web page.
' For sake of simplicity and performance,
' i let it just plain.
Set xlApp = New Excel.Application
Set wb = xlApp.Workbooks.Open(XFilename)
Set sh = wb.ActiveSheet
Dim rng As Range
Set rng = sh.Range(ValRng)
xlApp.Visible = True
Dim ff As Integer
ff = FreeFile
Open HFilename For Output As #ff
Dim Cell As Range
Dim iCols As Integer, iRows As Integer
iCols = rng.Columns.Count
iRows = rng.Rows.Count
Dim ir As Integer, ic As Integer
Print #ff, ""
Print #ff, "
"
For ir = 1 To iRows
Print #ff, "
"
For ic = 1 To iCols
If IsNumeric(rng.Cells(ir, ic).Value) Then
Print #ff, "
" & rng.Cells(ir, ic).Value & "
"
ElseIf IsEmpty(rng.Cells(ir, ic).Value) Then
Print #ff, "
" & " " & "
"
Else
Print #ff, "
" & rng.Cells(ir, ic).Value & "
"
End If
Next ic
Print #ff, "
"
Next ir
Print #ff, "
"
Close #ff
' Cleaning...
With xlApp
.DisplayAlerts = False
wb.Close
Set sh = Nothing
Set wb = Nothing
.Quit
End With
Set xlApp = Nothing
'Shows result...( ta-daaa!!;)
Shell "start " & Chr$(34) & HTMLFile & Chr$(34), vbNormal
End Sub
Private Sub cmdConvert_Click()
ConvertXLSToHtml XLSFile, HTMLFile, txtRange.Text
End Sub
Private Sub Command1_Click(Index As Integer)
With CDiag
Select Case Index
Case 0
.DefaultExt = "xls"
.DialogTitle = "Open Excel file..."
.Filter = "Xls Files (*.xls)|*.xls"
.FileName = "*.xls"
.ShowOpen
If (.FileName <> "" And .FileName <> "*.xls") Then
XLSFile = .FileName
End If
Case 1
.DefaultExt = "htm"
.DialogTitle = "Save Web file..."
.Filter = "HTML Files (*.htm)|*.htm"
.FileName = "*.htm"
.ShowSave
If (.FileName <> "" And .FileName <> "*.htm") Then
HTMLFile = .FileName
End If
End Select
End With
End Sub